Class-Prototyped-1.16/0000755000175000017500000000000014674671765013420 5ustar tobytobyClass-Prototyped-1.16/Changes0000444000175000017500000003060314674671765014713 0ustar tobytobyRevision history for Perl extension Class::Prototyped 1.16 Tue Sep 24 2024 - Fixed t/include.t test failure when PERL_USE_UNSAFE_INC=0 1.15 Fri Sep 20 2024 - ARGH! Missed updating version numbers on sub-packages 1.14 Fri Sep 20 2024 - Updated test file include.t to use static include_xxx.pl file for included module contents, fixing test issues on readonly file system 1.13 Wed Aug 28 2013 - Added version numbers to sub-packages to eliminate PAUSE indexer issues. 1.12 Thu Aug 22 2013 - Updated test suite to use getSlots(undef, 'rotated') to resolve issues with 5.18 due to the introduction of hash order randomization. 1.11 Tue Dec 18 2007 - Fixed error in synopsis (C::P->new is correct, C::P::new isn't). Thanks to Matthew Browning. - Added @$isa=@$isa changes to workaround @ISA issues in 5.10.0. 1.10 Tue Mar 15 2005 - Merlyn strongly suggested that I unify the behavior of new() for named classes and un-named objects. After much discussion, I concurred. This is a BACKWARDS INCOMPATIBLE change. Hopefully it will not affect too much code. In 1.01, calling new() on an un-named object was identical to calling Class::Prototyped->new(). In 1.10, calling new() on an un-named object ALSO adds 'class*' as a slot pointing to the original object. This also necessitated a change to clone. - Two new Class::Prototyped methods are added: clonePackage (a cross between clone and newPackage) and newCore (implements core object instantiation behavior). If you implement either method in any of your Class::Prototyped code, there will be problems! - Fixed a bug in Class::Prototyped::Mirror::Normal::new that affected superable calls to C::P objects following reflection on a non-C::P object blessed into a C::P class. 1.01 Sat Mar 20 2004 - Now using create_makefile_pl => 'traditional' because passthrough doesn't seem to work with subclassing (Thanks merlyn for reporting this) 1.00 Sat Mar 20 2004 - Now using Module::Build! - Now generating PPMs as well! - Long live Module::Build! 0.98 Mon Jan 19 2004 - Distribution updated to migrate Class directory into lib and update Manifest and Makefile.pl. 0.97 Mon Sep 22 2003 - Slot attribute 'profile' modified to support recording calling location. 0.96 Tue Sep 16 2003 - More POD changes and updates 0.95 Mon Sep 8 2003 - Minor changes to POD - Minor changes to test code 0.94 Thu Jan 9 2003 (not released) - Rationalized and codified attribute support - Moved addSlots parsing/checking code into separate method from implementation, thus eating up a good chunk of the optimizations. On the other hand, this improved the handling of error conditions in addSlots and exposes the parsing to external code. In addition, implementation of slots was moved into separate method so that the slots could be parsed, then modified in parsed form, and then passed to the implementor. - Cleared up bug that caused infinite recursion when non-C::P structured objects that inherit from C::P from call $self->reflect->super(). Using reflect on objects (not classes) that are not C::P structured is still fraught with peril, but super is at least safe. - Added support for defaultAttributes. - Unfortunately, we lost the performance battle. Package creation is running slightly faster than in 0.90. Package instantion from subs is running much faster. addSlots, however, is running around 20% slower (it's a hard call because there are both constant and proportional terms). Individual calls appear to be slightly faster, but each slot handled in the call appears to be somewhat slower. All in all, the optimizations applied have managed to keep in check the performance hits from all of the added functionality. - Added support for FIELD attribute 'autoload' (i.e. FIELD slots that are initialized with a subroutine reference - the first access to the FIELD slot causes the subroutine to be executed). Tied interface access to these slots is _not_ supported for the first call. - Added support for the FIELD attribute 'wantarray'. This looks at the wantarray value to determine whether to unwrap an array reference and return it as a list. - Added incomplete support for the METHOD attribute 'profile'. This keeps track of the number of calls to this method in a C::P::Mirror global. 0.93 Mon Jan 6 2003 (not released) - Lots of attempted and somewhat successful optimizations - Addition of :NO_CHECK import option that eliminates additional checks in order to improve performance - More work remains to be done in this area - packages are expensive, and any work that can be done to optimize this would be advantageous. 0.92 Fri Jan 3 2003 (not released) - Added support for extended slot syntax via anonymous arrays for addSlots - Migrated trailing character support (second * for parent slots, ! on methods, & on fields) to use slot attributes. First two notations maintained for backward compatibility, but deprecated. - Defined optimizations for extended slot syntax - Updated tests and documentation to use extended slot syntax - Updated getSlot to use extended slot syntax - Added support to getSlot for format parameter - Moved Carp::Croak lines to head of addSlots so object remains unchanged 0.91 Sun Dec 29 2002 (not released) - Added support for constant field slots using trailing & notation - Added tiedInterfacePackage to C::P::M - Modified C::P::new to respect return value of tiedInterfacePackage - tiedInterfacePackage is now read/write! - :TIED_INTERFACE is being removed (good riddance!) - tiedInterfacePackage is inherited when class packages are objectified - Oodles of tests on the new tied interface support - Tests for the new constant field slot support 0.90 Wed Dec 18 2002 - Moved addition of DESTROY symbol table entry in newPackage into code guarded by check for PREFIXED package name - Created $parent_DESTROY search code that looks for DESTROYs that aren't clones of C::P::DESTROY - Modified destroy and DESTROY so that parent slots aren't deleted until the destruction sequence on an object is complete - Updated destroy.t to include parent** slots, more explicit scope ordering (which fixed test variations related to changes in the order in which lexicals exit scope), as well as use of field slots - Added more tests to super.t - Code passes all tests under: ActivePerl 804 (based on v5.8.0) ActivePerl 633 (based on v5.6.1) ActivePerl 517 (based on v5.005_03) - Incremented version number to 0.90 to reflect code maturity level 0.11 (released 7/14/01) and prior: RCS file: /usr/local/cvsroot/perl/Class/Prototyped/Class/Prototyped.pm,v Working file: Class/Prototyped.pm head: 1.36 branch: locks: strict access list: symbolic names: keyword substitution: kv total revisions: 36; selected revisions: 36 description: ---------------------------- revision 1.36 date: 2001/07/15 01:05:37; author: ned; state: Exp; lines: +5 -1 added credit for chromatic ---------------------------- revision 1.35 date: 2001/07/15 01:05:08; author: ned; state: Exp; lines: +13 -7 More changes for DESTROY/import problems under 5.005 by chromatic ---------------------------- revision 1.34 date: 2001/07/15 00:54:27; author: ned; state: Exp; lines: +43 -20 5.005_03 changes by chromatic and ned ---------------------------- revision 1.33 date: 2001/07/13 00:09:57; author: ned; state: Exp; lines: +78 -33 Toby's bug fixes, added findImplementation ---------------------------- revision 1.32 date: 2001/07/12 01:10:47; author: ned; state: Exp; lines: +69 -36 Added Data::Dumper support. ---------------------------- revision 1.31 date: 2001/07/12 00:59:10; author: ned; state: Exp; lines: +20 -18 More changes and bug fixes ---------------------------- revision 1.30 date: 2001/07/11 22:27:37; author: ned; state: Exp; lines: +216 -203 With changes for reflection of anything, detecting odd numbers of args to addSlots, auto-numbering parent slots. ---------------------------- revision 1.29 date: 2001/07/11 19:24:32; author: ned; state: Exp; lines: +19 -17 Moved lexicals into globals ---------------------------- revision 1.28 date: 2001/07/11 19:15:28; author: ned; state: Exp; lines: +5 -2 changed version number ---------------------------- revision 1.27 date: 2001/07/11 19:15:05; author: ned; state: Exp; lines: +15 -11 Made sure that we don't pollute symbol tables. ---------------------------- revision 1.26 date: 2001/07/11 19:02:23; author: ned; state: Exp; lines: +19 -10 Fixed problems with include and vivification ---------------------------- revision 1.25 date: 2001/07/11 18:04:16; author: ned; state: Exp; lines: +5 -2 added =back ---------------------------- revision 1.24 date: 2001/07/11 17:49:20; author: ned; state: Exp; lines: +6 -2 Added Toby's blessed hash tie work ---------------------------- revision 1.23 date: 2001/07/11 16:41:59; author: ned; state: Exp; lines: +632 -208 More edits from Toby for adding tied-hash capability. Whew! major rework, again... ---------------------------- revision 1.22 date: 2001/07/11 05:05:00; author: ned; state: Exp; lines: +22 -9 More edits ---------------------------- revision 1.21 date: 2001/07/10 17:05:49; author: ned; state: Exp; lines: +8 -3 Fixed a couple of class reflection bugs ---------------------------- revision 1.20 date: 2001/07/10 03:34:48; author: ned; state: Exp; lines: +37 -15 Added debugging for global destruction ---------------------------- revision 1.19 date: 2001/07/10 02:11:07; author: ned; state: Exp; lines: +8 -6 fixed typos made by Ned ---------------------------- revision 1.18 date: 2001/07/10 02:05:28; author: ned; state: Exp; lines: +465 -214 Much more work by Toby. ---------------------------- revision 1.17 date: 2001/07/09 04:47:32; author: ned; state: Exp; lines: +160 -44 Fix clones and super methods; autovivification of classes after includes. ---------------------------- revision 1.16 date: 2001/07/08 23:54:14; author: ned; state: Exp; lines: +26 -12 Fixed POD ---------------------------- revision 1.15 date: 2001/07/08 23:43:18; author: ned; state: Exp; lines: +111 -38 (toby) Added super method to ::Mirror and :EZACCESS (ned) Added explanation of super, include to POD Cleaned up croak messages Do not do include if we have a symbol table rename _include as include so it's public ---------------------------- revision 1.14 date: 2001/07/08 19:49:27; author: ned; state: Exp; lines: +26 -49 Fixed POD docs ---------------------------- revision 1.13 date: 2001/07/08 19:31:25; author: ned; state: Exp; lines: +43 -35 More debugging ---------------------------- revision 1.12 date: 2001/07/08 18:23:37; author: ned; state: Exp; lines: +11 -3 added :REFLECT back in ---------------------------- revision 1.11 date: 2001/07/08 18:16:14; author: ned; state: Exp; lines: +6 -3 Fixed reflect on classes ---------------------------- revision 1.10 date: 2001/07/08 18:09:04; author: ned; state: Exp; lines: +15 -8 Added reflect to CORE::GLOBAL, changed :REFLECT to :EZACCESS ---------------------------- revision 1.9 date: 2001/07/08 16:16:55; author: ned; state: Exp; lines: +39 -45 bug fixes, fixed overloading ---------------------------- revision 1.8 date: 2001/07/08 07:41:34; author: ned; state: Exp; lines: +208 -193 Initial work by Ned on Toby's stuff. ---------------------------- revision 1.7 date: 2001/07/08 02:59:26; author: ned; state: Exp; lines: +259 -226 Perltidy --tabs --indent-columns=4 -pt=1 -bt=1 -sbt=1 -nbl ---------------------------- revision 1.6 date: 2001/07/08 02:25:58; author: ned; state: Exp; lines: +394 -191 Second rev from Toby, with POD ---------------------------- revision 1.5 date: 2001/07/08 02:17:46; author: ned; state: Exp; lines: +301 -297 First rev from Toby ---------------------------- revision 1.4 date: 2001/07/06 19:43:35; author: ned; state: Exp; lines: +148 -101 Added better test routines; got fields working right. Fixed DESTROY (was not destroying symbol tables). ---------------------------- revision 1.3 date: 2001/07/06 04:46:19; author: ned; state: Exp; lines: +58 -27 added ability to overload ref to provide "parent". Not sure this is useful yet. Also added class field pointing back at package for efficiency. ---------------------------- revision 1.2 date: 2001/07/06 00:49:36; author: ned; state: Exp; lines: +140 -29 Made Data::Dumping work; removed memory leak. ---------------------------- revision 1.1 date: 2001/07/05 22:27:47; author: ned; state: Exp; Initial revision Class-Prototyped-1.16/MANIFEST0000444000175000017500000000067314674671765014555 0ustar tobytobyBuild.PL Changes examples/graph.png examples/graphtest.pl lib/Class/Prototyped.pm lib/Class/Prototyped/Graph.pm lib/Class/Prototyped/why.pod Makefile.PL MANIFEST This list of files META.json META.yml perf/package_creation.pl perf/references.pl README t/autoload.t t/classReflect.t t/constant.t t/defaultAttributes.t t/delegate.t t/destroy.t t/extendedSyntax.t t/include.t t/include_xxx.pl t/reflectAny.t t/super.t t/test.t t/tied.t t/wrap.t Class-Prototyped-1.16/README0000444000175000017500000014522614674671765014310 0ustar tobytobyNAME "Class::Prototyped" - Fast prototype-based OO programming in Perl SYNOPSIS use strict; use Class::Prototyped ':EZACCESS'; $, = ' '; $\ = "\n"; my $p = Class::Prototyped->new( field1 => 123, sub1 => sub { print "this is sub1 in p" }, sub2 => sub { print "this is sub2 in p" } ); $p->sub1; print $p->field1; $p->field1('something new'); print $p->field1; my $p2 = Class::Prototyped->new( 'parent*' => $p, field2 => 234, sub2 => sub { print "this is sub2 in p2" } ); $p2->sub1; $p2->sub2; print ref($p2), $p2->field1, $p2->field2; $p2->field1('and now for something different'); print ref($p2), $p2->field1; $p2->addSlots( sub1 => sub { print "this is sub1 in p2" } ); $p2->sub1; print ref($p2), "has slots", $p2->reflect->slotNames; $p2->reflect->include( 'xx.pl' ); # includes xx.pl in $p2's package print ref($p2), "has slots", $p2->reflect->slotNames; $p2->aa(); # calls aa from included file xx.pl $p2->deleteSlots('sub1'); $p2->sub1; DESCRIPTION This package provides for efficient and simple prototype-based programming in Perl. You can provide different subroutines for each object, and also have objects inherit their behavior and state from another object. The structure of an object is inspected and modified through *mirrors*, which are created by calling "reflect" on an object or class that inherits from "Class::Prototyped". Installation instructions This module requires "Module::Build 0.24" to use the automated installation procedures. With "Module::Build" installed: Build.PL perl build test perl build install It can be installed under ActivePerl for Win32 by downloading the PPM from CPAN (the file has the extension ".ppm.zip"). To install, download the ".ppm.zip" file, uncompress it, and execute: ppm install Class-Prototyped.ppd The module can also be installed manually by copying "lib/Class/Prototyped.pm" to "perl/site/lib/Class/Prototyped.pm" (along with "Graph.pm" if you want it). WHEN TO USE THIS MODULE When I reach for "Class::Prototyped", it's generally because I really need it. When the cleanest way of solving a problem is for the code that uses a module to subclass from it, that is generally a sign that "Class::Prototyped" would be of use. If you find yourself avoiding the problem by passing anonymous subroutines as parameters to the "new" method, that's another good sign that you should be using prototype based programming. If you find yourself storing anonymous subroutines in databases, configuration files, or text files, and then writing infrastructure to handle calling those anonymous subroutines, that's yet another sign. When you expect the people using your module to want to change the behavior, override subroutines, and so forth, that's a sign. CONCEPTS Slots "Class::Prototyped" borrows very strongly from the language Self (see http://www.sun.com/research/self for more information). The core concept in Self is the concept of a slot. Think of slots as being entries in a hash, except that instead of just pointing to data, they can point to objects, code, or parent objects. So what happens when you send a message to an object (that is to say, you make a method call on the object)? First, Perl looks for that slot in the object. If it can't find that slot in the object, it searches for that slot in one of the object's parents (which we'll come back to later). Once it finds the slot, if the slot is a block of code, it evaluates the code and returns the return value. If the slot references data, it returns that data. If you assign to a data slot (through a method call), it modifies the data. Distinguishing data slots and method slots is easy - the latter are references to code blocks, the former are not. Distinguishing parent slots is not so easy, so instead a simple naming convention is used. If the name of the slot ends in an asterisk, the slot is a parent slot. If you have programmed in Self, this naming convention will feel very familiar. Reflecting In Self, to examine the structure of an object, you use a mirror. Just like using his shield as a mirror enabled Perseus to slay Medusa, holding up a mirror enables us to look upon an object's structure without name space collisions. Once you have a mirror, you can add and delete slots like so: my $cp = Class::Prototyped->new(); my $mirror = $cp->reflect(); $mirror->addSlots( field1 => 'foo', sub1 => sub { print "this is sub1 printing field1: '".$_[0]->field1."'\n"; }, ); $mirror->deleteSlot('sub1'); In addition, there is a more verbose syntax for "addSlots" where the slot name is replaced by an anonymous array - this is most commonly used to control the slot attributes. $cp->reflect->addSlot( [qw(field1 FIELD)] => 'foo', [qw(sub1 METHOD)] => sub { print "hi there.\n"; }, ); Because the mirror methods "super", "addSlot"("s"), "deleteSlot"("s"), and "getSlot"("s") are called frequently on objects, there is an import keyword ":EZACCESS" that adds methods to the object space that call the appropriate reflected variants. Slot Attributes Slot attributes allow the user to specify additional information and behavior relating to a specific slot in an extensible manner. For instance, one might want to mark a specific field slot as constant or to attach a description to a given slot. Slot attributes are divided up in two ways. The first is by the type of slot - "FIELD", "METHOD", or "PARENT". Some slot attributes apply to all three, some to just two, and some to only one. The second division is on the type of slot attribute: implementor These are responsible for implementing the behavior of a slot. An example is a "FIELD" slot with the attribute "constant". A slot is only allowed one implementor. All slot types have a default implementor. For "FIELD" slots, it is a read-write scalar. For "METHOD" slots, it is the passed anonymous subroutine. For "PARENT" slots, "implementor" and "filter" slot attributes don't really make sense. filter These filter access to the "implementor". The quintessential example is the "profile" attribute. When set, this increments a counter in $Class::Prototyped::Mirror::PROFILE::counts every time the underlying "FIELD" or "METHOD" is accessed. Filter attributes can be stacked, so each attribute is assigned a rank with lower values being closer to the "implementor" and higher values being closer to the caller. advisory These slot attributes serve one of two purposes. They can be used to store information about the slot (i.e. "description" attributes), and they can be used to pass information to the "addSlots" method (i.e. the "promote" attribute, which can be used to promote a new "PARENT" slot ahead of all the existing "PARENT" slots). There is currently no formal interface for creating your own attributes - if you feel the need for new attributes, please contact the maintainer first to see if it might make sense to add the new attribute to "Class::Prototyped". If not, the contact might provide enough impetus to define a formal interface. The attributes are currently defined in $Class::Prototyped::Mirror::attributes. Finally, see the "defaultAttributes" method for information about setting default attributes. This can be used, for instance, to turn on profiling everywhere. Classes vs. Objects In Self, everything is an object and there are no classes at all. Perl, for better or worse, has a class system based on packages. We decided that it would be better not to throw out the conventional way of structuring inheritance hierarchies, so in "Class::Prototyped", classes are first-class objects. However, objects are not first-class classes. To understand this dichotomy, we need to understand that there is a difference between the way "classes" and the way "objects" are expected to behave. The central difference is that "classes" are expected to persist whether or not that are any references to them. If you create a class, the class exists whether or not it appears in anyone's @ISA and whether or not there are any objects in it. Once a class is created, it persists until the program terminates. Objects, on the other hand, should follow the normal behaviors of reference-counted destruction - once the number of references to them drops to zero, they should miraculously disappear - the memory they used needs to be returned to Perl, their "DESTROY" methods need to be called, and so forth. Since we don't require this behavior of classes, it's easy to have a way to get from a package name to an object - we simply stash the object that implements the class in $Class::Prototyped::Mirror::objects{$package}. But we can't do this for objects, because if we do the object will persist forever because that reference will always exist. Weak references would solve this problem, but weak references are still considered alpha and unsupported ("$WeakRef::VERSION = 0.01"), and we didn't want to make "Class::Prototyped" dependent on such a module. So instead, we differentiate between classes and objects. In a nutshell, if an object has an explicit package name (*i.e.* something other than the auto-generated one), it is considered to be a class, which means it persists even if the object goes out of scope. To create such an object, use the "newPackage" method, like so (the encapsulating block exists solely to demonstrate that classes are not scoped): { my $object = Class::Prototyped->newPackage('MyClass', field => 1, double => sub {$_[0]->field*2} ); } print MyClass->double,"\n"; Notice that the class persists even though $object goes out of scope. If $object were created with an auto-generated package, that would not be true. Thus, for instance, it would be a very, very, very bad idea to add the package name of an object as a parent to another object - when the first object goes out of scope, the package will disappear, but the second object will still have it in it's @ISA. Except for the crucial difference that you should never, ever, ever make use of the package name for an object for any purpose other than printing it to the screen, objects and classes are simply different ways of inspecting the same entity. To go from an object to a package, you can do one of the following: $package = ref($object); $package = $object->reflect->package; The two are equivalent, although the first is much faster. Just remember, if $object is in an auto-generated package, don't do anything with that $package but print it. To go from a package to an object, you do this: $object = $package->reflect->object; Note that $package is simple the name of the package - the following code works perfectly: $object = MyClass->reflect->object; But keep in mind that $package has to be a class, not an auto-generated package name for an object. Class Manipulation This lets us have tons of fun manipulating classes at run time. For instance, if you wanted to add, at run-time, a new method to the "MyClass" class? Assuming that the "MyClass" inherits from "Class::Prototyped" or that you have specified ":REFLECT" on the "use Class::Prototyped" call, you simply write: MyClass->reflect->addSlot(myMethod => sub {print "Hi there\n"}); If you want to access a class that doesn't inherit from "Class::Prototyped", and you want to avoid specifying ":REFLECT" (which adds "reflect" to the "UNIVERSAL" package), you can make the call like so: my $mirror = Class::Prototyped::Mirror->new('MyClass'); $mirror->addSlot(myMethod => sub {print "Hi there\n"}); Just as you can "clone" objects, you can "clone" classes that are derived from "Class::Prototyped". This creates a new object that has a copy of all of the slots that were defined in the class. Note that if you simply want to be able to use "Data::Dumper" on a class, calling "MyClass->reflect->object" is the preferred approach. Even easier would be to use the "dump" mirror method. The code that implements reflection on classes automatically creates slot names for package methods as well as parent slots for the entries in @ISA. This means that you can code classes like you normally do - by doing the inheritance in @ISA and writing package methods. If you manually add subroutines to a package at run-time and want the slot information updated properly (although this really should be done via the "addSlots" mechanism, but maybe you're twisted:), you should do something like: $package->reflect->_vivified_methods(0); $package->reflect->_autovivify_methods; Parent Slots Adding parent slots is no different than adding normal slots - the naming scheme takes care of differentiating. Thus, to add $foo as a parent to $bar, you write: $bar->reflect->addSlot('fooParent*' => $foo); However, keeping with our concept of classes as first class objects, you can also write the following: $bar->reflect->addSlot('mixIn*' => 'MyMix::Class'); It will automatically require the module in the namespace of $bar and make the module a parent of the object. This can load a module from disk if needed. If you're lazy, you can add parents without names like so: $bar->reflect->addSlot('*' => $foo); The slots will be automatically named for the package passed in - in the case of "Class::Prototyped" objects, the package is of the form "PKG0x12345678". In the following example, the parent slot will be named "MyMix::Class*". $bar->reflect->addSlot('*' => 'MyMix::Class'); Parent slots are added to the inheritance hierarchy in the order that they were added. Thus, in the following code, slots that don't exist in $foo are looked up in $fred (and all of its parent slots) before being looked up in $jill. $foo->reflect->addSlots('fred*' => $fred, 'jill*' => $jill); Note that "addSlot" and "addSlots" are identical - the variants exist only because it looks ugly to add a single slot by calling "addSlots". If you need to reorder the parent slots on an object, look at "promoteParents". That said, there's a shortcut for prepending a slot to the inheritance hierarchy. Simply define 'promote' as a slot attribute using the extended slot syntax. Finally, in keeping with our principle that classes are first-class object, the inheritance hierarchy of classes can be modified through "addSlots" and "deleteSlots", just like it can for objects. The following code adds the $foo object as a parent of the "MyClass" class, prepending it to the inheritance hierarchy: MyClass->reflect->addSlots([qw(foo* promote)] => $foo); Operator Overloading In "Class::Prototyped", you do operator overloading by adding slots with the right name. First, when you do the "use" on "Class::Prototyped", make sure to pass in ":OVERLOAD" so that the operator overloading support is enabled. Then simply pass the desired methods in as part of the object creation like so: $foo = Class::Prototyped->new( value => 3, '""' => sub { my $self = shift; $self->value( $self->value + 1 ) }, ); This creates an object that increments its field "value" by one and returns that incremented value whenever it is stringified. Since there is no way to find out which operators are overloaded, if you add overloading to a *class* through the use of "use overload", that behavior will not show up as slots when reflecting on the class. However, "addSlots" does work for adding operator overloading to classes. Thus, the following code does what is expected: Class::Prototyped->newPackage('MyClass'); MyClass->reflect->addSlots( '""' => sub { my $self = shift; $self->value( $self->value + 1 ) }, ); $foo = MyClass->new( value => 2 ); print $foo, "\n"; Object Class The special parent slot "class*" is used to indicate object class. When you create "Class::Prototyped" objects by calling "Class::Prototyped->new()", the "class*" slot is not set. If, however, you create objects by calling "new" on a class or object that inherits from "Class::Prototyped", the slot "class*" points to the package name if "new" was called on a named class, or the object if "new" was called on an object. The value of this slot can be returned quite easily like so: $foo->reflect->class; Calling Inherited Methods Methods (and fields) inherited from prototypes or classes are *not* generally available using the usual Perl "$self->SUPER::something()" mechanism. The reason for this is that "SUPER::something" is hardcoded to the package in which the subroutine (anonymous or otherwise) was defined. For the vast majority of programs, this will be "main::", and thus "SUPER::" will look in @main::ISA (not a very useful place to look). To get around this, a very clever wrapper can be automatically placed around your subroutine that will automatically stash away the package to which the subroutine is attached. From within the subroutine, you can use the "super" mirror method to make an inherited call. However, because we'd rather not write code that attempts to guess as to whether or not the subroutine uses the "super" construct, you have to tell "addSlots" that the subroutine needs to have this wrapper placed around it. To do this, simply use the extended "addSlots" syntax (see the method description for more information) and pass in the slot attribute 'superable'. The following examples use the minimalist form of the extended syntax. For instance, the following code will work: use Class::Prototyped; my $p1 = Class::Prototyped->new( method => sub { print "this is method in p1\n" }, ); my $p2 = Class::Prototyped->new( '*' => $p1, [qw(method superable)]' => sub { print "this is method in p2 calling method in p1: "; $_[0]->reflect->super('method'); }, ); To make things easier, if you specify ":EZACCESS" during the import, "super" can be called directly on an object rather than through its mirror. The other thing of which you need to be aware is copying methods from one object to another. The proper way to do this is like so: $foo->reflect->addSlot($bar->reflect->getSlot('method')); When the "getSlot" method is called in an array context, it returns both the complete format for the slot identifier and the slot. This ensures that slot attributes are passed along, including the "superable" attribute. Finally, to help protect the code, the "super" method is smart enough to determine whether it was called within a wrapped subroutine. If it wasn't, it croaks indicating that the method should have had the "superable" attribute set when it was added. If you wish to disable this checking (which will improve the performance of your code, of course, but could result in very hard to trace bugs if you haven't been careful), see the import option ":SUPER_FAST". PERFORMANCE NOTES It is important to be aware of where the boundaries of prototyped based programming lie, especially in a language like Perl that is not optimized for it. For instance, it might make sense to implement every field in a database as an object. Those field objects would in turn be attached to a record class. All of those might be implemented using "Class::Prototyped". However, it would be very inefficient if every record that got read from the database was stored in a "Class::Prototyped" based object (unless, of course, you are storing code in the database). In that situation, it is generally good to choke off the prototype-based behavior for the individual record objects. For best performance, it is important to confine "Class::Prototyped" to those portions of the code where behavior is mutable from outside of the module. See the documentation for the "new" method of "Class::Prototyped" for more information about choking off "Class::Prototyped" behavior. There are a number of performance hits when using "Class::Prototyped", relative to using more traditional OO code. It is important to note that these generally lie in the instantiation and creation of classes and objects and not in the actual use of them. The scripts in the "perf" directory were designed for benchmarking some of this material. Class Instantiation The normal way of creating a class is like this: package Pack_123; sub a {"hi";} sub b {"hi";} sub c {"hi";} sub d {"hi";} sub e {"hi";} The most efficient way of doing that using "proper" "Class::Prototyped" methodology looks like this: Class::Prototyped->newPackage("Pack_123"); push(@P_123::slots, a => sub {"hi";}); push(@P_123::slots, b => sub {"hi";}); push(@P_123::slots, c => sub {"hi";}); push(@P_123::slots, d => sub {"hi";}); push(@P_123::slots, e => sub {"hi";}); Pack_123->reflect->addSlots(@P_123::slots); This approach ensures that the new package gets the proper default attributes and that the slots are created through "addSlots", thus ensuring that default attributes are properly implemented. It avoids multiple calls to "->reflect->addSlot", though, which improves performance. The idea behind pushing the slots onto an array is that it enables one to intersperse code with POD, since POD is not permitted inside of a single Perl statement. On a Pent 4 1.8GHz machine, the normal code runs in 120 usec, whereas the "Class::Prototyped" code runs in around 640 usec, or over 5 times slower. A straight call to "addSlots" with all five methods runs in around 510 usec. Code that creates the package and the mirror without adding slots runs in around 135 usec, so we're looking at an overhead of less than 100 usec per slot. In a situation where the "compile" time dominates the "execution" time (I'm using those terms loosely as much of what happens in "Class::Prototyped" is technically execution time, but it is activity that traditionally would happen at compile time), "Class::Prototyped" might prove to be too much overhead. On the otherhand, you may find that demand loading can cut much of that overhead and can be implemented less painfully than might otherwise be thought. Object Instantiation There is no need to even compare here. Blessing a hash into a class takes less than 2 usec. Creating a new "Class::Prototyped" object takes at least 60 or 70 times longer. The trick is to avoid creating unnecessary "Class::Prototyped" objects. If you know that all 10,000 database records are going to inherit all of their behavior from the parent class, there is no point in creating 10,000 packages and all the attendant overhead. The "new" method for "Class::Prototyped" demonstrates how to ensure that those state objects are created as normal Perl objects. Method Calls The good news is that method calls are just as fast as normal Perl method calls, inherited or not. This is because the existing Perl OO machinery has been hijacked in "Class::Prototyped". The exception to this is if "filter" slot attributes have been used, including "wantarray", "superable", and "profile". In that situation, the added overhead is that for a normal Perl subroutine call (which is faster than a method call because it is a static binding) Instance Variable Access The hash interface is not particularly fast, and neither is it good programming practice. Using the method interface to access fields is just as fast, however, as using normal getter/setter methods. IMPORT OPTIONS ":OVERLOAD" This configures the support in "Class::Prototyped" for using operator overloading. ":REFLECT" This defines "UNIVERSAL::reflect" to return a mirror for any class. With a mirror, you can manipulate the class, adding or deleting methods, changing its inheritance hierarchy, etc. ":EZACCESS" This adds the methods "addSlot", "addSlots", "deleteSlot", "deleteSlots", "getSlot", "getSlots", and "super" to "Class::Prototyped". This lets you write: $foo->addSlot(myMethod => sub {print "Hi there\n"}); instead of having to write: $foo->reflect->addSlot(myMethod => sub {print "Hi there\n"}); The other methods in "Class::Prototyped::Mirror" should be accessed through a mirror (otherwise you'll end up with way too much name space pollution for your objects:). Note that it is bad form for published modules to use ":EZACCESS" as you are polluting everyone else's namespace as well. If you really want ":EZACCESS" for code you plan to publish, contact the maintainer and we'll see what we can about creating a variant of ":EZACCESS" that adds the shortcut methods to a single class. Note that using ":EZACCESS" to do "$obj->addSlot()" is actually slower than doing "$obj->reflect->addSlot()". ":SUPER_FAST" Switches over to the fast version of "super" that doesn't check to see whether slots that use inherited calls were defined as superable. ":NEW_MAIN" Creates a "new" function in "main::" that creates new "Class::Prototyped" objects. Thus, you can write code like: use Class::Prototyped qw(:NEW_MAIN :EZACCESS); my $foo = new(say_hi => sub {print "Hi!\n";}); $foo->say_hi; ":TIED_INTERFACE" This is no longer supported. Sorry for the very short notice - if you have a specific need, please let me know and I will discuss your needs with you and determine whether they can be addressed in a manner that doesn't require you to rewrite your code, but still allows others to make use of less global control over the tied interfaces used. See "Class::Prototyped::Mirror::tiedInterfacePackage" for the preferred way of doing this. "Class::Prototyped" Methods new() - Construct a new "Class::Prototyped" object. A new object is created. If this is called on a class or object that inherits from "Class::Prototyped", and "class*" is not being passed as a slot in the argument list, the slot "class*" will be the first element in the inheritance list. When called on named classes, either via the package name or via the object (i.e. "MyPackage->reflect->object()"), "class*" is set to the package name. When called on an object, "class*" is set to the object on which "new" was called. The passed arguments are handed off to "addSlots". Note that "new" calls "newCore", so if you want to override "new", but want to ensure that your changes are applicable to "newPackage", "clone", and "clonePackage", you may wish to override "newCore". For instance, the following will define a new "Class::Prototyped" object with two method slots and one field slot: my $foo = Class::Prototyped->new( field1 => 123, sub1 => sub { print "this is sub1 in foo" }, sub2 => sub { print "this is sub2 in foo" }, ); The following will create a new "MyClass" object with one field slot and with the parent object $bar at the beginning of the inheritance hierarchy (just before "class*", which points to "MyClass"): my $foo = MyClass->new( field1 => 123, [qw(bar* promote)] => $bar, ); The following will create a new object that inherits behavior from $bar with one field slot, "field1", and one parent slot, "class*", that points to $bar. my $foo = $bar->new( field1 => 123, ); If you want to create normal Perl objects as child objects of a "Class::Prototyped" class in order to improve performance, implement your own standard Perl "new" method: Class::Prototyped->newPackage('MyClass'); MyClass->reflect->addSlot( new => sub { my $class = shift; my $self = {}; bless $self, $class; return $self; } ); It is still safe to use "$obj->reflect->super()" in code that runs on such an object. All other reflection will automatically return the same results as inspecting the class to which the object belongs. newPackage() - Construct a new "Class::Prototyped" object in a specific package. Just like "new", but instead of creating the new object with an arbitrary package name (actually, not entirely arbitrary - it's generally based on the hash memory address), the first argument is used as the name of the package. This creates a named class. The same behavioral rules for "class*" described above for "new" apply to "newPackage" (in fact, "new" calls "newPackage"). If the package name is already in use, this method will croak. clone() - Duplicate me Duplicates an existing object or class and allows you to add or override slots. The slot definition is the same as in new(). my $p2 = $p1->clone( sub1 => sub { print "this is sub1 in p2" }, ); It calls "newCore" to create the new object*, so if you have overridden "new", you should contemplate overriding "clone" in order to ensure that behavioral changes made to "new" that would be applicable to "clone" are implemented. Or simply override "newCore". clonePackage() Just like "clone", but instead of creating the new object with an arbitrary package name (actually, not entirely arbitrary - it's generally based on the hash memory address), the first argument is used as the name of the package. This creates a named class. If the package name is already in use, this method will croak. newCore() This implements the core functionality involved in creating a new object. The first passed parameter will be the name of the caller - either "new", "newPackage", "clone", or "clonePackage". The second parameter is the name of the package if applicable (i.e. for "newPackage" and "clonePackage") calls, "undef" if inapplicable. The remainder of the parameters are any slots to be added to the newly created object/package. If called with "new" or "newPackage", the "class*" slot will be prepended to the slot list if applicable. If called with "clone" or "clonePackage", all slots on the receiver will be prepended to the slot list. If you wish to add behavior to object instantiation that needs to be present in all four of the instantiators (i.e. instance tracking), it may make sense to override "newCore" so that you implement the code in only one place. reflect() - Return a mirror for the object or class The structure of an object is modified by using a mirror. This is the equivalent of calling: Class::Prototyped::Mirror->new($foo); destroy() - The destroy method for an object You should never need to call this method. However, you may want to override it. Because we had to directly specify "DESTROY" for every object in order to allow safe destruction during global destruction time when objects may have already destroyed packages in their @ISA, we had to hook "DESTROY" for every object. To allow the "destroy" behavior to be overridden, users should specify a "destroy" method for their objects (by adding the slot), which will automatically be called by the "Class::Prototyped::DESTROY" method after the @ISA has been cleaned up. This method should be defined to allow inherited method calls (*i.e.* should use ""[qw(destroy superable)]"" to define the method) and should call "$self->reflect->super('destroy');" at some point in the code. Here is a quick overview of the default destruction behavior for objects: * "Class::Prototyped::DESTROY" is called because it is linked into the package for all objects at instantiation time * All no longer existent entries are stripped from @ISA * The inheritance hierarchy is searched for a "DESTROY" method that is not "Class::Prototyped::DESTROY". This "DESTROY" method is stashed away for a later call. * The inheritance hierarchy is searched for a "destroy" method and it is called. Note that the "Class::Prototyped::destroy" method, which will either be called directly because it shows up in the inheritance hierarchy or will be called indirectly through calls to "$self->reflect->super('destroy');", will delete all non-parent slots from the object. It leaves parent slots alone because the destructors for the parent slots should not be called until such time as the destruction of the object in question is complete (otherwise inherited destructors might still be executing, even though the object to which they belong has already been destroyed). This means that the destructors for objects referenced in non-parent slots may be called, temporarily interrupting the execution sequence in "Class::Prototyped::destroy". * The previously stashed "DESTROY" method is called. * The parent slots for the object are finally removed, thus enabling the destructors for any objects referenced in those parent slots to run. * Final "Class::Prototyped" specific cleanup is run. "Class::Prototyped::Mirror" Methods These are the methods you can call on the mirror returned from a "reflect" call. If you specify ":EZACCESS" in the "use Class::Prototyped" line, "addSlot", "addSlots", "deleteSlot", "deleteSlots", "getSlot", "getSlots", and "super" will be callable on "Class::Prototyped" objects as well. new() - Creates a new "Class::Prototyped::Mirror" object Normally called via the "reflect" method, this can be called directly to avoid using the ":REFLECT" import option for reflecting on non "Class::Prototyped" based classes. autoloadCall() If you add an "AUTOLOAD" slot to an object, you will need to get the name of the subroutine being called. autoloadCall() returns the name of the subroutine, with the package name stripped off. package() - Returns the name of the package for the object object() - Returns the object itself class() - Returns the "class*" slot for the underlying object dump() - Returns a Data::Dumper string representing the object addSlot() - An alias for "addSlots" addSlots() - Add or replace slot definitions Allows you to add or replace slot definitions in the receiver. $p->reflect->addSlots( fred => 'this is fred', doSomething => sub { print 'doing something with ' . $_[1] }, ); $p->doSomething( $p->fred ); In addition to the simple form, there is an extended syntax for specifying the slot. In place of the slotname, pass an array reference composed like so: "addSlots( [$slotName, $slotType, %slotAttributes] => $slotValue );" $slotName is simply the name of the slot, including the trailing "*" if it is a parent slot. $slotType should be 'FIELD', 'METHOD', or 'PARENT'. %slotAttributes should be a list of attribute/value pairs. It is common to use qw() to reduce the amount of typing: $p->reflect->addSlot( [qw(bar FIELD)] => "this is a field", ); $p->reflect->addSlot( [qw(bar FIELD constant 1)] => "this is a constant field", ); $p->reflect->addSlot( [qw(foo METHOD)] => sub { print "normal method.\n"; }, ); $p->reflect->addSlot( [qw(foo METHOD superable 1)] => sub { print "superable method.\n"; }, ); $p->reflect->addSlot( [qw(parent* PARENT)] => $parent, ); $p->reflect->addSlot( [qw(parent2* PARENT promote 1)] => $parent2, ); To make using the extended syntax a bit less cumbersome, however, the following shortcuts are allowed: * $slotType can be omitted. In this case, the slot's type will be determined by inspecting the slot's name (to determine if it is a parent slot) and the slot's value (to determine whether it is a field or method slot). The $slotType value can, however, be used to supply a reference to a code object as the value for a field slot. Note that this means that "FIELD", "METHOD", and "PARENT" are not legal attribute names (since this would make parsing difficult). * If there is only one attribute and if the value is 1, then the value can be omitted. Using both of the above contractions, the following are valid short forms for the extended syntax: $p->reflect->addSlot( [qw(bar constant)] => "this is a constant field", ); $p->reflect->addSlot( [qw(foo superable)] => sub { print "superable method.\n"; }, ); $p->reflect->addSlot( [qw(parent2* promote)] => $parent2, ); The currently defined slot attributes are as follows: "FIELD" Slots "constant" ("implementor") When true, this defines the field slot as constant, disabling the ability to modify it using the "$object->field($newValue)" syntax. The value may still be modified using the hash syntax (i.e. $object->{field} = $newValue). This is mostly useful if you have an object method call that takes parameters, but you wish to replace it on a given object with a hard-coded value by using a field (which makes inspecting the value of the slot through "Data::Dumper" much easier than if you use a "METHOD" slot to return the constant, since code objects are opaque). "autoload" ("filter", rank 50) The passed value for the "FIELD" slot should be a subroutine that returns the desired value. Upon the first access, the subroutine will be called, the return value hard-coded into the object by adding the slot (including all otherwise specified attributes), and the value then returned. Useful for implementing constant slots that are costly to initialize, especially those that return lists of "Class::Prototyped" objects! "profile" ("filter", rank 80) If "profile" is set to 1, increments "$Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slot Name}" everytime the slot is accessed. If "profile" is set to 2, increments "$Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slot Name}->{$caller}" everytime the slot is accessed, where $caller is "$file ($line)". "wantarray" ("filter", rank 90) If the field specifies a reference to an array and the call is in list context, dereferences the array and returns a list of values. "description" ("advisory") Can be used to specify a description. No real support for this yet beyond that! "METHOD" Slots "superable" ("filter", rank 10) When true, this enables the "$self->reflect->super( . . . )" calls for this method slot. "profile" ("filter", rank 90) See "FIELD" slots for explanation. "overload" ("advisory") Set automatically for methods that implement operator overloading. "description" ("advisory") See "FIELD" slots for explanation. "PARENT" Slots "promote" ("advisory") When true, this parent slot is promoted ahead of any other parent slots on the object. This attribute is ephemeral - it is not returned by calls to "getSlot". "description" ("advisory") See "FIELD" slots for explanation. deleteSlot() - An alias for deleteSlots deleteSlots() - Delete one or more of the receiver's slots by name This will let you delete existing slots in the receiver. If those slots were defined in the receiver's inheritance hierarchy, those inherited definitions will now be available. my $p1 = Class::Prototyped->new( field1 => 123, sub1 => sub { print "this is sub1 in p1" }, sub2 => sub { print "this is sub2 in p1" } ); my $p2 = Class::Prototyped->new( 'parent*' => $p1, sub1 => sub { print "this is sub1 in p2" }, ); $p2->sub1; # calls $p2.sub1 $p2->reflect->deleteSlots('sub1'); $p2->sub1; # calls $p1.sub1 $p2->reflect->deleteSlots('sub1'); $p2->sub1; # still calls $p1.sub1 super() - Call a method defined in a parent The call to a method defined on a parent that is obscured by the current one looks like so: $self->reflect->super('method_name', @params); slotNames() - Returns a list of all the slot names This is passed an optional type parameter. If specified, it should be one of 'FIELD', 'METHOD', or 'PARENT'. For instance, the following will print out a list of all slots of an object: print join(', ', $obj->reflect->slotNames)."\n"; The following would print out a list of all field slots: print join(', ', $obj->reflect->slotNames('FIELD')."\n"; The parent slot names are returned in the same order for which inheritance is done. slotType() - Given a slot name, determines the type This returns 'FIELD', 'METHOD', or 'PARENT'. It croaks if the slot is not defined for that object. parents() - Returns a list of all parents Returns a list of all parent object (or package names) for this object. allParents() - Returns a list of all parents in the hierarchy Returns a list of all parent objects (or package names) in the object's hierarchy. withAllParents() - Same as above, but includes self in the list allSlotNames() - Returns a list of all slot names defined for the entire inheritance hierarchy Note that this will return duplicate slot names if inherited slots are obscured. getSlot() - Returns the requested slot When called in scalar context, this returns the thing in the slot. When called in list context, it returns both the complete form of the extended syntax for specifying a slot name and the thing in the slot. There is an optional parameter that can be used to modify the format of the return value in list context. The allowable values are: * 'default' - the extended slot syntax and the slot value are returned * 'simple' - the slot name and the slot value are returned. Note that in this mode, there is no access to any attributes the slot may have * 'rotated' - the slot name and the following hash are returned like so: $slotName => { attribs => %slotAttribs, type => $slotType, value => $slotValue }, The latter two options are quite useful when used in conjunction with the "getSlots" method. getSlots() - Returns a list of all the slots This returns a list of extended syntax slot specifiers and their values ready for sending to "addSlots". It takes first the optional parameter passed to "slotNames" which specifies the type of slot ('FIELD', 'METHOD', 'PARENT', or "undef") and then the optional parameter passed to "getSlot", which specifies the format for the return value. If the latter is 'simple', the returned values can be passed to "addSlots", but any non-default slot attributes (i.e. "superable" or "constant") will be lost. If the latter is 'rotated', the returned values are completely inappropriate for passing to "addSlots". Both 'simple' and 'rotated' are appropriate for assigning the return values into a hash. For instance, to add all of the field slots in $bar to $foo: $foo->reflect->addSlots($bar->reflect->getSlots('FIELD')); To get a list of all of the slots in the 'simple' format: my %barSlots = $bar->reflect->getSlots(undef, 'simple'); To get a list of all of the superable method slots in the 'rotated' format: my %barMethods = $bar->reflect->getSlots('METHOD', 'rotated'); foreach my $slotName (%barMethods) { delete $barMethods{$slotName} unless $barMethods{$slotName}->{attribs}->{superable}; } promoteParents() - This changes the ordering of the parent slots This expects a list of parent slot names. There should be no duplicates and all of the parent slot names should be already existing parent slots on the object. These parent slots will be moved forward in the hierarchy in the order that they are passed. Unspecified parent slots will retain their current positions relative to other unspecified parent slots, but as a group they will be moved to the end of the hierarchy. tiedInterfacePackage() - This specifies the tied interface package This allows you to specify the sort of tied interface you wish to offer when code accesses the object as a hash reference. If no parameter is passed, this will return the current tied interface package active for the object. If a parameter is passed, it should specify either the package name or an alias. The currently known aliases are: default This specifies "Class::Prototyped::Tied::Default" as the tie class. The default behavior is to allow access to existing fields, but attempts to create fields, access methods, or delete slots will croak. This is the tie class used by "Class::Prototyped" (unless you do something very naughty and call "Class::Prototyped->reflect->tiedInterfacePackage($not_default)"), and as such is the fallback behavior for classes and objects if they don't get a different value from their inheritance. autovivify This specifies "Class::Prototyped::Tied::AutoVivify" as the tie class. The behavior of this package allows access to existing fields, will automatically create field slots if they don't exist, and will allow deletion of field slots. Attempts to access or delete method or parent slots will croak. Calls to "new" and "clone" will use the tied interface in use on the existing object/package. When "reflect" is called for the first time on a class package, it will use the tied interface of its first parent class (i.e. $ISA[0]). If that package has not yet had "reflect" called on it, it will check its parent, and so on and so forth. If none of the packages in the primary inheritance fork have been reflected upon, the value for "Class::Prototyped" will be used, which should be "default". defaultAttributes() - get and set default attributes This isn't particularly pretty. The general syntax looks something like: my $temp = MyClass->reflect->defaultAttributes; $temp->{METHOD}->{superable} = 1; MyClass->reflect->defaultAttributes($temp); The return value from "defaultAttributes" is a hash with the keys 'FIELD', 'METHOD', and 'PARENT'. The values are either "undef" or hash references consisting of the attributes and their default values. Modify the data structure as desired and pass it back to "defaultAttributes" to change the default attributes for that object or class. Note that default attributes are not inherited dynamically - the inheritance occurs when a new object is created, but from that point on changes to a parent object are not inherited by the child. Global changes can be effected by modifying the "defaultAttributes" for "Class::Prototyped" in a sufficiently early "BEGIN" block. Note that making global changes like this is "not" recommended for production modules as it may interfere with other modules that rely upon "Class::Prototyped". wrap() unwrap() delegate() delegate name => slot name can be string, regex, or array of same. slot can be slot name, or object, or 2-element array with slot name or object and method name. You can delegate to a parent. include() - include a package or external file You can "require" an arbitrary file in the namespace of an object or class without adding to the parents using include() : $foo->include( 'xx.pl' ); will include whatever is in xx.pl. Likewise for modules: $foo->include( 'MyModule' ); will search along your @INC path for "MyModule.pm" and include it. You can specify a second parameter that will be the name of a subroutine that you can use in your included code to refer to the object into which the code is being included (as long as you don't change packages in the included code). The subroutine will be removed after the include, so don't call it from any subroutines defined in the included code. If you have the following in "File.pl": sub b {'xxx.b'} sub c { return thisObject(); } # DON'T DO THIS! thisObject()->reflect->addSlots( 'parent*' => 'A', d => 'added.d', e => sub {'xxx.e'}, ); And you include it using: $mirror->include('File.pl', 'thisObject'); Then the "addSlots" will work fine, but if sub "c" is called, it won't find thisObject(). AUTHOR Written by Ned Konz, perl@bike-nomad.com and Toby Ovod-Everett, toby@ovod-everett.org. 5.005_03 porting by chromatic. Toby Ovod-Everett is currently maintaining the package. LICENSE Copyright 2001-2004 Ned Konz and Toby Ovod-Everett. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO Class::SelfMethods Class::Object Class::Classless Class-Prototyped-1.16/META.json0000444000175000017500000000342714674671765015045 0ustar tobytoby{ "abstract" : "Fast prototype-based OO programming in Perl", "author" : [ "Written by Ned Konz, perl@bike-nomad.com and Toby Ovod-Everett, toby@ovod-everett.org. 5.005_03 porting by chromatic." ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Class-Prototyped", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.42" } } }, "provides" : { "Class::Prototyped" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Mirror" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Mirror::Normal" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Mirror::PROFILE" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Mirror::SUPER" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Tied" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Tied::AutoVivify" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" }, "Class::Prototyped::Tied::Default" : { "file" : "lib/Class/Prototyped.pm", "version" : "1.16" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "1.16", "x_serialization_backend" : "JSON::PP version 4.16" } Class-Prototyped-1.16/Makefile.PL0000444000175000017500000000044214674671765015370 0ustar tobytoby# Note: this file was auto-generated by Module::Build::Compat version 0.4234 use ExtUtils::MakeMaker; WriteMakefile ( 'PL_FILES' => {}, 'EXE_FILES' => [], 'INSTALLDIRS' => 'site', 'NAME' => 'Class::Prototyped', 'VERSION_FROM' => 'lib/Class/Prototyped.pm', 'PREREQ_PM' => {} ) ; Class-Prototyped-1.16/Build.PL0000444000175000017500000000224314674671765014713 0ustar tobytobyuse Module::Build 0.42; my $class = Module::Build->subclass( class => 'Module::Build::ClassPrototyped', code => q{ sub ppm_name { my $self = shift; mkdir('MSWin32-x86-multi-thread'); return 'MSWin32-x86-multi-thread/' . $self->dist_dir; } sub ACTION_ppmzip { my $self = shift; $self->depends_on('ppmdist'); my $ppmzip = $self->dist_dir().'.ppm.zip'; my $ppm_name = $self->ppm_name(); unlink($ppmzip); system("zip -9 $ppmzip *.ppd $ppm_name.tar.gz"); } sub ACTION_ppmdist { my ($self) = @_; $self->depends_on('build', 'html', 'ppd'); opendir(TEMPDIR, $self->blib().'/libdoc'); foreach my $i (grep(!/^\.\.?$/, readdir(TEMPDIR))) { unlink($self->blib().'/libdoc/'.$i); } closedir(TEMPDIR); rmdir($self->blib().'/libdoc'); $self->add_to_cleanup($self->ppm_name); $self->make_tarball($self->blib, $self->ppm_name); } }, ); my $build = $class->new( module_name => 'Class::Prototyped', license => 'perl', configure_requires => { 'Module::Build' => 0.42 }, requires => { }, create_makefile_pl => 'traditional', create_readme => 1, ); $build->create_build_script; Class-Prototyped-1.16/perf/0000755000175000017500000000000014674671765014354 5ustar tobytobyClass-Prototyped-1.16/perf/references.pl0000444000175000017500000000137114674671765017032 0ustar tobytobyuse Benchmark qw(cmpthese timeit); package My::Funky::Class; sub foo { print "hi\n"; } package main; $My::Funky::Class::mirrors = { $package => 'foo' }; mytimethese(500_000, { stringref => sub { my %foo = %{"$package\::"}; }, 'bless_variable' => sub { bless {}, $package; }, 'bless_constant' => sub { bless {}, 'My::Funky::Class'; }, }); sub get_package { my $string = shift; my $pkg = \%main::; foreach (split(/::/, $string)) {$pkg = $pkg->{"$_\::"};} return $pkg; } sub mytimethese { my($iter, $codehash) = @_; foreach my $desc (sort keys %$codehash) { print "$desc:" . ' 'x(50-length($desc)); my $time = timeit($iter, $codehash->{$desc}); print sprintf('%8.2f usec', ($time->[1]+$time->[2])*1_000_000/$time->[5])."\n"; } }Class-Prototyped-1.16/perf/package_creation.pl0000444000175000017500000001346114674671765020173 0ustar tobytobyuse Benchmark qw(cmpthese); my $alliter = 5000; &remote_exec($alliter, ' package Pack_%i%; sub a {"hi";} sub b {"hi";} sub c {"hi";} sub d {"hi";} sub e {"hi";} '); =pod &remote_exec($alliter, ' package Pack_%i%; @Pack_%i%::ISA = qw(Class::Prototyped); Pack_%i%->reflect(); '); &remote_exec($alliter, ' package Pack_%i%; @Pack_%i%::ISA = qw(Class::Prototyped); sub foo {"hi";} Pack_%i%->reflect(); '); &remote_exec($alliter, ' package Pack_%i%; @Pack_%i%::ISA = qw(Class::Prototyped); Pack_%i%->reflect()->addSlot(foo => sub {"hi";}); '); =cut &remote_exec($alliter, ' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect(); '); =pod &remote_exec($alliter, ' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect(); Pack_%i%->reflect->_vivified_methods(0); Pack_%i%->reflect->_autovivify_methods; '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(); Pack_%i%->reflect->addSlots(); Pack_%i%->reflect->addSlots(); Pack_%i%->reflect->addSlots(); Pack_%i%->reflect->addSlots(); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(a => sub {"hi";}); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(a => sub {"hi";}); Pack_%i%->reflect->addSlots(b => sub {"hi";}); Pack_%i%->reflect->addSlots(c => sub {"hi";}); Pack_%i%->reflect->addSlots(d => sub {"hi";}); Pack_%i%->reflect->addSlots(e => sub {"hi";}); '); =cut &remote_exec($alliter, ' package Pack_%i%; @Pack_%i%::ISA = qw(Class::Prototyped); sub a {"hi";} sub b {"hi";} sub c {"hi";} sub d {"hi";} sub e {"hi";} Pack_%i%->reflect(); '); =pod &remote_exec($alliter,' @main::stuff = ( a => sub {"hi";}, b => sub {"hi";}, c => sub {"hi";}, d => sub {"hi";}, e => sub {"hi";}); ',' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(@main::stuff); '); =cut &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots( a => sub {"hi";}, b => sub {"hi";}, c => sub {"hi";}, d => sub {"hi";}, e => sub {"hi";}); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(a => sub {"hi";}); Pack_%i%->reflect->addSlots(b => sub {"hi";}); Pack_%i%->reflect->addSlots(c => sub {"hi";}); Pack_%i%->reflect->addSlots(d => sub {"hi";}); Pack_%i%->reflect->addSlots(e => sub {"hi";}); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); push(@P_%i%::slots, a => sub {"hi";}); push(@P_%i%::slots, b => sub {"hi";}); push(@P_%i%::slots, c => sub {"hi";}); push(@P_%i%::slots, d => sub {"hi";}); push(@P_%i%::slots, e => sub {"hi";}); Pack_%i%->reflect->addSlots(@P_%i%::slots); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); push(@P_%i%::slots, a => sub {"hi";}, b => sub {"hi";}, c => sub {"hi";}, d => sub {"hi";}, e => sub {"hi";}); Pack_%i%->reflect->addSlots(@P_%i%::slots); '); &remote_exec($alliter,' @main::stuff = (f => "f", g => "g", h => "h", i => "i", j => "j"); ',' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(@main::stuff); '); &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(f => "f", g => "g", h => "h", i => "i", j => "j"); '); &remote_exec($alliter,' $p = Class::Prototyped->new(a => sub {"hi";}, b => sub {"hi";}, c => sub {"hi";}, d => sub {"hi";}, e => sub {"hi";}, f => "f", g => "g", h => "h", i => "i", j => "j"); ',' $Pack_%i% = $p->clone; '); =pod &remote_exec($alliter,' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots( [qw(a METHOD)] => sub {"hi";}, [qw(b METHOD)] => sub {"hi";}, [qw(c METHOD)] => sub {"hi";}, [qw(d METHOD)] => sub {"hi";}, [qw(e METHOD)] => sub {"hi";} ); '); &remote_exec(100_000,' Class::Prototyped->newPackage("Pack"); Pack->reflect->addSlots( [qw(a METHOD)] => sub {"hi";}, [qw(b METHOD)] => sub {"hi";}, [qw(c METHOD)] => sub {"hi";}, [qw(d METHOD)] => sub {"hi";}, [qw(e METHOD)] => sub {"hi";} ); $main::mirror = Pack->reflect; ',' $main::mirror->package; $main::mirror->_slots; '); &remote_exec(100_000,' Class::Prototyped->newPackage("Pack"); Pack->reflect->addSlots( [qw(a METHOD)] => sub {"hi";}, [qw(b METHOD)] => sub {"hi";}, [qw(c METHOD)] => sub {"hi";}, [qw(d METHOD)] => sub {"hi";}, [qw(e METHOD)] => sub {"hi";} ); $main::mirror = Pack->reflect; ',' ref(${$main::mirror}); { my $tied = tied(%{ ${ $main::mirror } }); $main::mirror->_autovivify_parents unless $tied->vivified_parents; $main::mirror->_autovivify_methods unless $tied->vivified_methods; $tied->slots; } '); &remote_exec($alliter,' @main::stuff = ( [qw(a METHOD)] => sub {"hi";}, [qw(b METHOD)] => sub {"hi";}, [qw(c METHOD)] => sub {"hi";}, [qw(d METHOD)] => sub {"hi";}, [qw(e METHOD)] => sub {"hi";} ); ',' Class::Prototyped->newPackage("Pack_%i%"); Pack_%i%->reflect->addSlots(@main::stuff); '); =cut sub remote_exec { my($iter, $init, $snippet) = @_; unless ($snippet) { $snippet = $init; $init = ''; } $init =~ s/\t/ /g; $snippet =~ s/\t/ /g; (my $temp = $snippet) =~ s/\%i\%/123/g; my(@lines) = split(/\n/, $temp); chomp(my $temp = pop(@lines)); print $init; print join("\n", @lines); print "\n$temp" . ' 'x(72-length($temp)); open(TEMP, "|$^X") or die "Unable to open $^X.\n"; sleep(1); print TEMP "use Class::Prototyped qw(:NO_CHECK);\nuse Benchmark;\nBEGIN {$init\$main::start = Benchmark->new();}\n"; foreach my $i (1..$iter) { (my $temp = $snippet) =~ s/\%i\%/$i/g; print TEMP $temp; } print TEMP "\$main::time = main::timediff(Benchmark->new(), \$main::start);\n"; print TEMP "print sprintf('%6d'.\"\n\", (\$main::time->[1]+\$main::time->[2])*1_000_000/$iter);\n"; close TEMP; } Class-Prototyped-1.16/lib/0000755000175000017500000000000014674671765014166 5ustar tobytobyClass-Prototyped-1.16/lib/Class/0000755000175000017500000000000014674671765015233 5ustar tobytobyClass-Prototyped-1.16/lib/Class/Prototyped/0000755000175000017500000000000014674671765017404 5ustar tobytobyClass-Prototyped-1.16/lib/Class/Prototyped/why.pod0000444000175000017500000000070014674671765020712 0ustar tobytoby=pod =head1 Why Class::Prototyped? =head1 Background: Prototypes vs. Classes =head2 The "usual way": classes =head2 Object orientation without classes =head2 What are Prototypes =head2 Prototypes and Self =head1 What Class::Prototyped can do for you Class::Prototyped and Design Patterns Singleton objects without explicit classes Adapters Proxies Wrappers Aspect-Oriented Programming and Class::Prototyped =cut # vim: set ft=pod Class-Prototyped-1.16/lib/Class/Prototyped/Graph.pm0000444000175000017500000000342414674671765021004 0ustar tobytoby# Graph an object structure using GraphViz. use Class::Prototyped; use GraphViz; use IO::File; package Class::Prototyped::Mirror; $Class::Prototyped::Mirror::VERSION = '1.16'; my %graphOpts = ( R => 1, # H or V orientation i => 'png', # output format u => 0, # output image map? s => 1, # what kind of image map? ); sub graphOptions { shift if ref( $_[0] ); %graphOpts = ( %graphOpts, @_ ); } # look familiar? sub visitAllParents { my $mirror = shift; my $sub = shift; my $userData = shift; my $stack = shift || []; my $seen = shift || {}; push ( @$stack, $mirror ); $sub->( $parentMirror, $userData, $stack ); foreach my $parent ( $mirror->parents ) { next unless UNIVERSAL::can( $parent, 'reflect' ); my $parentMirror = $parent->reflect; $parentMirror->visitAllParents( $sub, $userData, $stack, $seen ); } pop (@$stack); } sub _graphOneObject { my $mirror = shift; my $data = shift; my $g = $data->[0]; my $slotName = $data->[1]; my $stack = shift; my $name = $stack->[-1]->getSlot($slotName); $g->add_node($name); my $fromName; if ( @$stack >= 2 ) { $fromName = $stack->[-2]->getSlot($slotName); $g->add_edge( $fromName, $name ); } } sub graph { shift if UNIVERSAL::isa( $_[0], 'Class::Prototyped::Mirror' ); my $slotName = shift; my $outfile = 'graph.png'; my $g = GraphViz->new( rankdir => $graphOpts{R} || 0 ); foreach my $obj (@_) { my $mirror = $obj->reflect; $mirror->visitAllParents( \&_graphOneObject, [ $g, $slotName ] ); } my $output = IO::File->new( $outfile, 'w' ) or die "can't open $outfile: $!\n"; $output->print( eval "\$g->as_$graphOpts{i}()" ); $output->close(); if ( $graphOpts{u} ) { STDOUT->print( exists( $graphOpts{s} ) ? $g->as_imap : $g->as_ismap() ); } } 1; Class-Prototyped-1.16/lib/Class/Prototyped.pm0000444000175000017500000026341214674671765017750 0ustar tobytoby############################################################################# # # Class::Prototyped - Fast prototype-based OO programming in Perl # # Author: Ned Konz and Toby Ovod-Everett ############################################################################# # Copyright 2001-2024 Ned Konz and Toby Ovod-Everett. All rights reserved. # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # For comments, questions, bugs or general interest, feel free to # contact Toby Ovod-Everett at toby@ovod-everett.org ############################################################################# # Class::Prototyped - Fast prototype-based OO programming in Perl package Class::Prototyped::Mirror; sub PREFIX() { 'PKG0x' } sub PREFIX_LENGTH() { 5 } package Class::Prototyped; use strict; use Carp(); $Class::Prototyped::VERSION = '1.16'; sub import { while (my $symbol = shift) { if ($symbol eq ':OVERLOAD') { unless (scalar keys %Class::Prototyped::overloadable_symbols) { eval "use overload"; @Class::Prototyped::overloadable_symbols{ map { split } values %overload::ops } = undef; } } elsif ($symbol eq ':REFLECT') { *UNIVERSAL::reflect = sub { Class::Prototyped::Mirror->new($_[0]) }; } elsif ($symbol eq ':EZACCESS') { no strict 'refs'; foreach my $call ( qw(addSlot addSlots deleteSlot deleteSlots getSlot getSlots super) ) { *{$call} = sub { my $obj = shift->reflect; UNIVERSAL::can($obj, $call)->($obj, @_); }; } } elsif ($symbol eq ':SUPER_FAST') { *Class::Prototyped::Mirror::super = \&Class::Prototyped::Mirror::super_fast; } elsif ($symbol eq ':NEW_MAIN') { *main::new = sub { Class::Prototyped->new(@_) }; } } } # Constructor. Pass in field definitions. sub new { my $class = shift; Carp::croak("odd number of slot parameters to new\n") if scalar(@_) % 2; $class->newCore('new', undef, @_); } sub newPackage { my $class = shift; my $package = shift; Carp::croak("odd number of slot parameters to newPackage\n") if scalar(@_) % 2; $class->newCore('newPackage', $package, @_); } # Creates a copy of an object sub clone { my $original = shift; Carp::croak("odd number of slot parameters to clone\n") if scalar(@_) % 2; $original->newCore('clone', undef, @_); } sub clonePackage { my $original = shift; my $package = shift; Carp::croak("odd number of slot parameters to clonePackage\n") if scalar(@_) % 2; $original->newCore('clonePackage', $package, @_); } sub newCore { my $class = shift; my $caller = shift; my $package = shift; my $isPackage = substr($caller, -7) eq 'Package'; my $isNew = substr($caller, 0, 3) eq 'new'; my $isClone = substr($caller, 0, 5) eq 'clone'; Carp::croak("odd number of slot parameters to $caller\n") if scalar(@_) % 2; my $class_mirror = $class->reflect; my($self, $tied); { no strict 'refs'; if ( $isPackage ) { if (scalar(keys %{"$package\::"})) { Carp::croak( "attempt to use newPackage with already existing package\n" . "package: $package"); } my %self; tie %self, $class_mirror->tiedInterfacePackage(); $tied = tied %self; $Class::Prototyped::Mirror::objects{$package} = $self = \%self; } else { $self = {}; $package = Class::Prototyped::Mirror::PREFIX . substr("$self", 7, -1); # HASH($package) tie %$self, $class->reflect->tiedInterfacePackage(); $tied = tied %$self; *{"$package\::DESTROY"} = \&Class::Prototyped::DESTROY; } } $tied->package($package); @{ $tied->{isa} } = qw(Class::Prototyped); $tied->{vivified_parents} = 1; $tied->{vivified_methods} = 1; $tied->{defaults} = $class_mirror->_defaults; bless $self, $package; # in my own package my $parsedSlots = scalar @_ || $isClone ? $self->reflect->addSlotsParser( ( $isClone ? $class->reflect->getSlots() : () ), @_ ) : []; if ( $isNew ) { my $classstar = ( ref($class) && substr(ref($class), 0, Class::Prototyped::Mirror::PREFIX_LENGTH) ne Class::Prototyped::Mirror::PREFIX ) ? ref($class) : $class; # allow object for named class to provide a class name if (!(grep { $_->[0] eq 'class*' } @$parsedSlots) && $classstar ne 'Class::Prototyped') { unshift(@$parsedSlots, @{$self->reflect->addSlotsParser('class*' => $classstar)}); } } $self->reflect->addParsedSlots($parsedSlots) if scalar(@$parsedSlots); return $self; } sub reflect { return $Class::Prototyped::Mirror::mirrors{ $_[0] } || Class::Prototyped::Mirror->new($_[0]); } sub destroy { my $self = shift; my $mirror = $self->reflect; my(@otherOrder) = @{$mirror->_otherOrder}; $mirror->deleteSlots(@otherOrder); } # Remove my symbol table sub DESTROY { my $self = shift; my $package = ref($self); if ((substr($package, 0, Class::Prototyped::Mirror::PREFIX_LENGTH) eq Class::Prototyped::Mirror::PREFIX) && ($package ne 'Class::Prototyped')) { no strict 'refs'; my $tied = tied(%$self) or return; my $parentOrder = $tied->{parentOrder}; my $isa = $tied->{isa}; my $slots = $tied->{slots}; my (@deadIndices); foreach my $i (0 .. $#$parentOrder) { my $parent = $slots->{ $parentOrder->[$i] }; my $parentPackage = ref($parent) || $parent; push (@deadIndices, $i) unless scalar(keys %{"$parentPackage\::"}); } foreach my $i (@deadIndices) { delete($slots->{ $parentOrder->[$i] }); splice(@$parentOrder, $i, 1); splice(@$isa, $i, 1); } # this is required to re-cache @ISA delete ${"$package\::"}{'::ISA::CACHE::'}; @$isa=@$isa; my $parent_DESTROY; my (@isa_queue) = @{"$package\::ISA"}; my (%isa_cache); while (my $pkg = shift @isa_queue) { exists $isa_cache{$pkg} and next; my $code = *{"$pkg\::DESTROY"}{CODE}; if (defined $code && $code != \&Class::Prototyped::DESTROY) { $parent_DESTROY = $code; last; } unshift (@isa_queue, @{"$pkg\::ISA"}); $isa_cache{$pkg} = undef; } $self->destroy; # call the user destroy function $parent_DESTROY->($self) if defined $parent_DESTROY; $self->reflect->deleteSlots($self->reflect->slotNames('PARENT')); foreach my $key (keys %{"$package\::"}) { delete ${"$package\::"}{$key}; } # this only works because we're not a multi-level package: delete($main::{"$package\::"}); delete($Class::Prototyped::Mirror::parents{$package}); } } $Class::Prototyped::Mirror::ending = 0; sub END { $Class::Prototyped::Mirror::ending = 1 } package Class::Prototyped::Tied; $Class::Prototyped::Tied::VERSION = '1.16'; @Class::Prototyped::Tied::DONT_LIE_FOR = qw(Data::Dumper); sub TIEHASH { bless $_[1] || { package => undef, isa => undef, parentOrder => [], otherOrder => [], slots => {}, types => {}, attribs => {}, defaults => undef, vivified_parents => 0, vivified_methods => 0, }, $_[0]; } sub FIRSTKEY { $_[0]->{dont_lie} = 0; my $caller = (caller(0))[0]; foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) { $_[0]->{dont_lie} = $caller eq $i and last; } $_[0]->{iter} = 1; $_[0]->{cachedOrder} = [@{ $_[0]->{parentOrder} }, @{ $_[0]->{otherOrder} }]; unless ($_[0]->{dont_lie}) { my $slots = $_[0]->{slots}; @{ $_[0]->{cachedOrder} } = grep { !UNIVERSAL::isa($slots->{$_}, 'CODE') } @{ $_[0]->{cachedOrder} }; } return $_[0]->{cachedOrder}->[0]; } sub NEXTKEY { return $_[0]->{cachedOrder}->[ $_[0]->{iter}++ ]; } sub EXISTS { exists $_[0]->{slots}->{ $_[1] } or return 0; UNIVERSAL::isa($_[0]->{slots}->{ $_[1] }, 'CODE') or return 1; my $dont_lie = 0; my $caller = (caller(0))[0]; foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) { $dont_lie = $caller eq $i and last; } return $dont_lie ? 1 : 0; } sub CLEAR { Carp::croak("attempt to call CLEAR on the hash interface" . " of a Class::Prototyped object\n"); } sub package { return $_[0]->{package} unless @_ > 1; no strict 'refs'; $_[0]->{isa} = \@{"$_[1]\::ISA"}; $_[0]->{package} = $_[1]; } #### Default Tied implementation package Class::Prototyped::Tied::Default; $Class::Prototyped::Tied::Default::VERSION = '1.16'; @Class::Prototyped::Tied::Default::ISA = qw(Class::Prototyped::Tied); sub STORE { my $slots = $_[0]->{slots}; Carp::croak( "attempt to access non-existent slot through tied hash object interface" ) unless exists $slots->{ $_[1] }; Carp::croak( "attempt to access METHOD slot through tied hash object interface") if UNIVERSAL::isa($slots->{ $_[1] }, 'CODE'); Carp::croak( "attempt to modify parent slot through the tied hash object interface") if substr($_[1], -1) eq '*'; $slots->{ $_[1] } = $_[2]; } sub FETCH { my $slots = $_[0]->{slots}; Carp::croak( "attempt to access non-existent slot through tied hash object interface:\n" . "$_[1]") unless exists $slots->{ $_[1] }; if (UNIVERSAL::isa($slots->{ $_[1] }, 'CODE')) { my $dont_lie = 0; my $caller = (caller(0))[0]; foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) { $dont_lie = $caller eq $i and last; } Carp::croak( "attempt to access METHOD slot through tied hash object interface") unless $dont_lie; } $slots->{ $_[1] }; } sub DELETE { Carp::croak "attempt to delete a slot through tied hash object interface"; } #### AutoVivifying Tied implementation package Class::Prototyped::Tied::AutoVivify; $Class::Prototyped::Tied::AutoVivify::VERSION = '1.16'; @Class::Prototyped::Tied::AutoVivify::ISA = qw(Class::Prototyped::Tied); sub STORE { my $slots = $_[0]->{slots}; Carp::croak( "attempt to modify parent slot through the tied hash object interface") if substr($_[1], -1) eq '*'; if (exists $slots->{ $_[1] }) { Carp::croak( "attempt to access METHOD slot through tied hash object interface") if UNIVERSAL::isa($slots->{ $_[1] }, 'CODE'); } else { my $slot = $_[1]; $slots->{ $_[1] } = $_[2]; my $implementation = bless sub { @_ > 1 ? $slots->{$slot} = $_[1] : $slots->{$slot}; }, 'Class::Prototyped::FieldAccessor'; no strict 'refs'; local $^W = 0; # suppress redefining messages. *{ $_[0]->package . "::$slot" } = $implementation; push (@{ $_[0]->{otherOrder} }, $slot); $_[0]->{types}->{$slot} = 'FIELD'; } Carp::croak( "attempt to access non-existent slot through tied hash object interface" ) unless exists $slots->{ $_[1] }; $slots->{ $_[1] } = $_[2]; } sub FETCH { my $slots = $_[0]->{slots}; if (exists $slots->{ $_[1] } and UNIVERSAL::isa($slots->{ $_[1] }, 'CODE')) { my $dont_lie = 0; my $caller = (caller(0))[0]; foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) { $dont_lie = $caller eq $i and last; } Carp::croak( "attempt to access METHOD slot through tied hash object interface") unless $dont_lie; } $slots->{ $_[1] }; } sub EXISTS { exists $_[0]->{slots}->{ $_[1] }; } sub DELETE { my $slots = $_[0]->{slots}; if (UNIVERSAL::isa($slots->{ $_[1] }, 'CODE') && (caller(0))[0] ne 'Data::Dumper') { Carp::croak "attempt to delete METHOD slot through tied hash object interface"; } my $package = $_[0]->package; my $slot = $_[1]; { no strict 'refs'; my $name = "$package\::$slot"; # save the glob... local *old = *{$name}; # and restore everything else local *new; foreach my $type (qw(HASH IO FORMAT SCALAR ARRAY)) { my $elem = *old{$type}; next if !defined($elem); *new = $elem; } *{$name} = *new; } my $otherOrder = $_[0]->{otherOrder}; @$otherOrder = grep { $_ ne $slot } @$otherOrder; delete $slots->{$slot}; # and delete the data/sub ref delete $_[0]->{types}->{$slot}; } # Everything that deals with modifying or inspecting the form # of an object is done through a reflector. package Class::Prototyped::Mirror; $Class::Prototyped::Mirror::VERSION = '1.16'; $Class::Prototyped::Mirror::PROFILE::VERSION = '1.16'; $Class::Prototyped::Mirror::SUPER::VERSION = '1.16'; sub new { my $class = shift; my($entity) = @_; if ( ref($entity) ) { if (substr(ref($entity), 0, Class::Prototyped::Mirror::PREFIX_LENGTH) eq Class::Prototyped::Mirror::PREFIX) { return bless \$entity, 'Class::Prototyped::Mirror'; } elsif ($Class::Prototyped::Mirror::objects{ ref($entity) } == $entity) { return $Class::Prototyped::Mirror::mirrors{ $entity } ||= bless \$entity, 'Class::Prototyped::Mirror'; } else { return Class::Prototyped::Mirror::Normal->new($entity); } } my $object; unless ($object = $Class::Prototyped::Mirror::objects{ $entity }) { my (%self); my $tiepkg; if ($entity eq 'Class::Prototyped') { $tiepkg = 'Class::Prototyped::Tied::Default'; } else { no strict 'refs'; $tiepkg = eval { ${"$entity\::ISA"}[0]->reflect->tiedInterfacePackage() }; $tiepkg = Class::Prototyped->reflect->tiedInterfacePackage() if $@; } tie %self, $tiepkg; $object = $Class::Prototyped::Mirror::objects{ $entity } = \%self; tied(%self)->package($entity); my $defaults; if ($entity eq 'Class::Prototyped') { $defaults = {FIELD => undef, METHOD => undef, PARENT => undef}; } else { no strict 'refs'; $defaults = eval { ${"$entity\::ISA"}[0]->reflect->_defaults() }; $defaults = Class::Prototyped->reflect->_defaults() if $@; } tied(%self)->{defaults} = $defaults; bless $object, $entity; } return $Class::Prototyped::Mirror::mirrors{ $entity } ||= bless \$object, 'Class::Prototyped::Mirror'; } #This code exists to support calling ->reflect->super on a "normal" object that #is blessed into a C::P class. package Class::Prototyped::Mirror::Normal; $Class::Prototyped::Mirror::Normal::VERSION = '1.16'; @Class::Prototyped::Mirror::Normal::ISA = qw(Class::Prototyped::Mirror); sub new { my $class = shift; my($entity) = @_; my $temp = Class::Prototyped::Mirror->new(ref($entity)); my $self = bless \(my $o = ${$temp}), $class; $Class::Prototyped::Mirror::Normal::superselfs->{$self} = $entity; return $self; } sub super { my $mirror = shift; (bless \$Class::Prototyped::Mirror::Normal::superselfs->{$mirror}, 'Class::Prototyped::Mirror')->super(@_); } sub DESTROY { delete $Class::Prototyped::Mirror::Normal::superselfs->{$_[0]}; } package Class::Prototyped::Mirror; #### Interface to tied object sub autoloadCall { my $mirror = shift; my $package = $mirror->package(); no strict 'refs'; my $call = ${"$package\::AUTOLOAD"}; $call =~ s/.*:://; return $call; } sub package { ref(${ $_[0] }); } sub tiedInterfacePackage { my $self = shift; if ($_[0]) { my $package = { 'default' => 'Class::Prototyped::Tied::Default', 'autovivify' => 'Class::Prototyped::Tied::AutoVivify', }->{$_[0]} || $_[0]; if ($package eq $_[0] && scalar(keys %{"$package\::"}) == 0) { eval "use $package"; Carp::croak "attempt to import package for :TIED_INTERFACE failed:\n$package" if $@; } tie %{ ${ $self } }, $package, tied(%{ ${ $self } }); return $package; } else { return ref(tied(%{ ${ $self } })); } } sub defaultAttributes { my $mirror = shift; tied(%{ ${ $mirror } })->{defaults} = $_[0] if scalar(@_); my $defaults = $mirror->_defaults; my $retval = {}; $retval->{FIELD} = defined $defaults->{FIELD} ? {%{$defaults->{FIELD}}} : undef; $retval->{METHOD} = defined $defaults->{METHOD} ? {%{$defaults->{METHOD}}} : undef; $retval->{PARENT} = defined $defaults->{PARENT} ? {%{$defaults->{PARENT}}} : undef; return $retval; } sub _isa { tied(%{ ${ $_[0] } })->isa; } sub _parentOrder { my $tied = tied(%{ ${ $_[0] } }); $_[0]->_autovivify_parents unless $tied->{vivified_parents}; $tied->{parentOrder}; } sub _otherOrder { my $tied = tied(%{ ${ $_[0] } }); $_[0]->_autovivify_methods unless $tied->{vivified_methods}; $tied->{otherOrder}; } sub _slotOrder { my $tied = tied(%{ ${ $_[0] } }); $_[0]->_autovivify_parents unless $tied->{vivified_parents}; $_[0]->_autovivify_methods unless $tied->{vivified_methods}; [@{ $tied->{parentOrder} }, @{ $tied->{otherOrder} }]; } sub _slots { my $tied = tied(%{ ${ $_[0] } }); $_[0]->_autovivify_parents unless $tied->{vivified_parents}; $_[0]->_autovivify_methods unless $tied->{vivified_methods}; $tied->{slots}; } sub _types { tied(%{ ${ $_[0] } })->{types}; } sub _attribs { tied(%{ ${ $_[0] } })->{attribs}; } sub _defaults { tied(%{ ${ $_[0] } })->{defaults}; } sub _vivified_parents { @_ > 1 ? tied(%{ ${ $_[0] } })->{vivified_parents} = $_[1] : tied(%{ ${ $_[0] } })->{vivified_parents}; } sub _vivified_methods { @_ > 1 ? tied(%{ ${ $_[0] } })->{vivified_methods} = $_[1] : tied(%{ ${ $_[0] } })->{vivified_methods}; } #The following returns package, _isa, _parentOrder, _otherOrder, #_slots, _types, _attribs, and _defaults; sub _everything { my $tied = tied(%{ ${ $_[0] } }); $_[0]->_autovivify_parents unless $tied->{vivified_parents}; $_[0]->_autovivify_methods unless $tied->{vivified_methods}; return ( ref(${ $_[0] }), $tied->{isa}, $tied->{parentOrder}, $tied->{otherOrder}, $tied->{slots}, $tied->{types}, $tied->{attribs}, $tied->{defaults}, ); } #### Autovivifivation support sub _autovivify_parents { my $tied = tied(%{ ${ $_[0] } }); return if $tied->{vivified_parents}; my $mirror = shift; $tied->{vivified_parents} = 1; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; if (scalar(grep { UNIVERSAL::isa($_, 'Class::Prototyped') } @$isa) && $isa->[-1] ne 'Class::Prototyped') { push (@$isa, 'Class::Prototyped'); no strict 'refs'; delete ${"$package\::"}{'::ISA::CACHE::'}; # re-cache @ISA @$isa=@$isa; } if (@{$parentOrder}) { Carp::croak("attempt to autovivify in the " . "presence of an existing parentOrder\n" . "package: $package"); } my @isa = @$isa; pop (@isa) if scalar(@isa) && $isa[-1] eq 'Class::Prototyped'; foreach my $parentPackage (@isa) { my $count = ''; my $slot = "$parentPackage$count*"; while (exists $slots->{$slot} || $slot eq 'self*') { $slot = $parentPackage . (++$count) . '*'; } push (@$parentOrder, $slot); $slots->{$slot} = $parentPackage; $types->{$slot} = 'PARENT'; } } sub _autovivify_methods { my $tied = tied(%{ ${ $_[0] } }); return if $tied->{vivified_methods}; my $mirror = shift; $tied->{vivified_methods} = 1; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; no strict 'refs'; foreach my $slot (grep { $_ ne 'DESTROY' } keys %{"$package\::"}) { my $code = *{"$package\::$slot"}{CODE} or next; ref($code) =~ /^Class::Prototyped::FieldAccessor/ and next; Carp::croak("the slot self* is inviolable") if $slot eq 'self*'; if (exists $slots->{$slot}) { Carp::croak("you overwrote a slot via an include $slot") if !UNIVERSAL::isa($slots->{$slot}, 'CODE') || $slots->{$slot} != $code; } else { push (@$otherOrder, $slot); $slots->{$slot} = $code; $types->{$slot} = 'METHOD'; } } } sub object { $_[0]->_autovivify_parents; $_[0]->_autovivify_methods; ${ $_[0] }; } sub class { return $_[0]->_slots->{'class*'}; } sub dump { eval "package main; use Data::Dumper;" unless (scalar keys(%Data::Dumper::)); Data::Dumper->Dump([ $_[0]->object ], [ $_[0]->package ]); } sub slotStruct_name () {0}; sub slotStruct_value () {1}; sub slotStruct_type () {2}; sub slotStruct_attribs () {3}; sub slotStruct_implementor () {4}; sub slotStruct_filters () {5}; sub slotStruct_advisories () {6}; #### The support for attribute rationalization is not very fancy $Class::Prototyped::Mirror::attributes = { FIELD => { constant => { type => 'implementor', code => sub { my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_; $slotAttribs->{constant} = 1; return bless sub { $slots->{$slotName}; }, 'Class::Prototyped::FieldAccessor::Constant'; } }, autoload => { type => 'filter', rank => 50, code => sub { my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_; if ($slotAttribs->{autoload} = $slotAttribs->{autoload} ? 1 : undef) { my $self = $mirror->object; $implementation = bless sub { my $retval = &$slotValue; my $attribs = $self->reflect->_attribs->{$slotName}; delete($attribs->{autoload}); $self->reflect->addSlot([$slotName, %$attribs] => $retval); return $retval; }, 'Class::Prototyped::FieldAccessor::Autoload'; } return $implementation; } }, profile => { type => 'filter', rank => 80, code => sub { my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_; my $profileLevel = $slotAttribs->{profile}; if ($profileLevel) { package Class::Prototyped::Mirror::PROFILE; my $old_implementation = $implementation; my $package = ref( ${ $mirror } ); $implementation = sub { my $caller = ''; if ($profileLevel == 2) { my($pack, $file, $line) = caller; $caller = "$file ($line)"; $Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}->{$caller}++; } else { $Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}++; } goto &$old_implementation; }; } return $implementation; }, }, 'wantarray' => { type => 'filter', rank => 90, code => sub { my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_; if ($slotAttribs->{'wantarray'} = $slotAttribs->{'wantarray'} ? 1 : undef) { my $old_implementation = $implementation; $implementation = bless sub { my $retval = &$old_implementation; if (ref($retval) eq 'ARRAY' && wantarray) { return (@$retval); } else { return $retval; } }, 'Class::Prototyped::FieldAccessor::Wantarray'; } return $implementation; } }, description => { type => 'advisory', }, }, METHOD => { superable => { type => 'filter', rank => 10, code => sub { my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_; if ($slotAttribs->{superable} = $slotAttribs->{superable} ? 1 : undef) { package Class::Prototyped::Mirror::SUPER; my $old_implementation = $implementation; my $package = ref( ${ $mirror } ); $implementation = sub { local $Class::Prototyped::Mirror::SUPER::package = $package; &$old_implementation; }; package Class::Prototyped::Mirror; } return $implementation; } }, profile => { type => 'filter', rank => 90, code => sub { my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_; my $profileLevel = $slotAttribs->{profile}; if ($profileLevel) { package Class::Prototyped::Mirror::PROFILE; my $old_implementation = $implementation; my $package = ref( ${ $mirror } ); $implementation = sub { my $caller = ''; if ($profileLevel == 2) { my($pack, $file, $line) = caller; $caller = "$file ($line)"; $Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}->{$caller}++; } else { $Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}++; } goto &$old_implementation; }; } return $implementation; }, }, overload => { type => 'advisory', }, description => { type => 'advisory', }, }, PARENT => { description => { type => 'advisory', }, promote => { type => 'advisory', }, }, }; sub addSlotsParser { my $mirror = shift; Carp::croak("odd number of arguments to addSlotsParser\n") if scalar(@_) % 2; my($package, undef, undef, undef, $slots, undef, undef, $defaults) = $mirror->_everything(); my(@retvals); while (my($slotThing, $slotValue) = splice(@_, 0, 2)) { my($slotName, $slotType, $slotAttribs, $slotImplementor, $slotFilters, $slotAdvisories); my $isCode = UNIVERSAL::isa($slotValue, 'CODE'); if (ref($slotThing) eq 'ARRAY') { $slotName = $slotThing->[0]; my $temp = $slotThing->[1] || ''; if ($temp eq 'METHOD' || $temp eq 'FIELD' || $temp eq 'PARENT') { $slotType = $temp; $temp = 2; } else { $slotType = $isCode ? 'METHOD' : (substr($slotName, -1) eq '*' ? 'PARENT' : 'FIELD'); $temp = 1; } if ($#{$slotThing} >= $temp) { if ($#{$slotThing} == $temp) { $slotAttribs = defined $defaults->{$slotType} ? { %{$defaults->{$slotType}}, $slotThing->[$temp] => 1 } : { $slotThing->[$temp] => 1 }; } else { $slotAttribs = defined $defaults->{$slotType} ? { %{$defaults->{$slotType}}, @{$slotThing}[$temp..$#{$slotThing}] } : { @{$slotThing}[$temp..$#{$slotThing}] }; } } elsif (defined $defaults->{$slotType}) { $slotAttribs = { %{$defaults->{$slotType}} }; } if ($slotType eq 'METHOD') { Carp::croak("it is not permitted to use '!' notation in conjunction with slot attributes") if substr($slotName, -1) eq '!'; Carp::croak("method slots have to have CODE refs as values") if !$isCode; } elsif ($slotType eq 'PARENT') { Carp::croak("it is not permitted to use '**' notation in conjunction with slot attributes") if substr($slotName, -2, 1) eq '*'; } } else { $slotName = $slotThing; $slotType = $isCode ? 'METHOD' : (substr($slotName, -1) eq '*' ? 'PARENT' : 'FIELD'); if (defined $defaults->{$slotType}) { $slotAttribs = { %{$defaults->{$slotType}} }; } # Slots that end in '!' mean that the method is superable if ($slotType eq 'METHOD' && substr($slotName, -1) eq '!') { $slotName = substr($slotName, 0, -1); $slotAttribs->{superable} = 1; } # Temporary support for & if ($slotType eq 'FIELD' && substr($slotName, -1) eq '&') { $slotName = substr($slotName, 0, -1); $slotAttribs->{constant} = 1; } # Slots that end in '**' mean to push the slot # to the front of the parents list. if ($slotType eq 'PARENT' && substr($slotName, -2) eq '**') { $slotName = substr($slotName, 0, -1); # xyz** => xyz* $slotAttribs->{promote} = 1; } } if ($slotType eq 'METHOD' && exists($Class::Prototyped::overloadable_symbols{$slotName})) { $slotAttribs->{overload} = 1; } else { Carp::croak("can't use slot attribute overload for slots that aren't overloadable") if ($slotAttribs->{overload} && !exists($Class::Prototyped::overloadable_symbols{$slotName})); } Carp::croak("slots should end in * if and only if the type is parent") if ( (substr($slotName, -1) eq '*') != ($slotType eq 'PARENT') && !$slotAttribs->{overload} ); if ($slotName eq '*') { $slotName = (ref($slotValue) || $slotValue) . $slotName; } if(scalar(keys(%{$slotAttribs}))) { my $attributes = $Class::Prototyped::Mirror::attributes->{$slotType}; foreach my $attrib (keys %{$slotAttribs}) { Carp::croak("$slotType slots cannot have the '$attrib' attribute.") unless exists $attributes->{$attrib}; my $atype = $attributes->{$attrib}->{type}; if ($atype eq 'filter') { push(@{$slotFilters}, $attrib); } elsif ($atype eq 'advisory') { push(@{$slotAdvisories}, $attrib); } elsif ($atype eq 'implementor') { Carp::croak("slots cannot have more than one implementor.") if defined($slotImplementor); $slotImplementor = $attributes->{$attrib}->{code} if $slotAttribs->{$attrib}; } else { Carp::croak("unknown attribute type '$atype' for '$attrib'."); } } if (defined $slotFilters) { @{$slotFilters} = map { $attributes->{$_}->{code} } sort { $attributes->{$a}->{rank} <=> $attributes->{$b}->{rank} || $a cmp $b } @{$slotFilters}; } if (defined $slotAdvisories) { @{$slotAdvisories} = grep {defined} map { $attributes->{$_}->{code} } sort @{ $slotAdvisories }; } } Carp::croak("the slot self* is inviolable") if $slotName eq 'self*'; Carp::croak("Can only use operator names for method slots\nslot: $slotName") if ( exists($Class::Prototyped::overloadable_symbols{$slotName}) && $slotType ne 'METHOD' ); if ($slotType eq 'PARENT') { Carp::croak("parent slots cannot be code blocks") if ($isCode); unless (UNIVERSAL::isa($slotValue, 'Class::Prototyped') || (ref(\$slotValue) eq 'SCALAR' && defined $slotValue)) { Carp::croak("attempt to add parent that isn't a " . "Class::Prototyped or package name\n" . "package: $package slot: $slotName parent: $slotValue"); } if (UNIVERSAL::isa($slotValue, $package)) { Carp::croak("attempt at recursive inheritance\n" . "parent $slotValue is a package $package"); } } elsif ($slotType eq 'METHOD') { Carp::croak("cannot replace DESTROY method for unnamed objects") if ($slotName eq 'DESTROY' && substr($package, 0, PREFIX_LENGTH) eq PREFIX); } push(@retvals, [$slotName, $slotValue, $slotType, $slotAttribs, $slotImplementor, $slotFilters, $slotAdvisories]); } return \@retvals; } sub addParsedSlots { my $mirror = shift; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything(); while (@{$_[0]}) { my($slotName, $slotValue, $slotType, $slotAttribs, $slotImplementor, $slotFilters, $slotAdvisories) = @{ shift @{$_[0]} }; &deleteSlots($mirror, $slotName) if exists($slots->{$slotName}); $slots->{$slotName} = $slotValue; #everything goes into the slots!!!!! if ($slotType eq 'PARENT') { my $parentPackage = ref($slotValue) || $slotValue; if (substr($parentPackage, 0, PREFIX_LENGTH) eq PREFIX) { $Class::Prototyped::Mirror::parents{$package}->{$slotName} = $slotValue; } else { Carp::carp( "it is recommended to use ->reflect->include for mixing in named files." ) if $parentPackage =~ /\.p[lm]$/i; no strict 'refs'; if (!ref($slotValue) && !(scalar keys(%{"$parentPackage\::"}))) { $mirror->include($parentPackage); } } my $splice_point = $slotAttribs->{promote} ? 0 : @$parentOrder; delete $slotAttribs->{promote}; splice(@$isa, $splice_point, 0, $parentPackage); { #Defends against ISA caching problems no strict 'refs'; delete ${"$package\::"}{'::ISA::CACHE::'}; @$isa = @$isa; } splice(@$parentOrder, $splice_point, 0, $slotName); } else { my $implementation = defined $slotImplementor ? $slotImplementor->($mirror, $slotName, $slotValue, $slotAttribs, undef, $slots) : ( $slotType eq 'METHOD' ? $slotValue : bless sub { @_ > 1 ? $slots->{$slotName} = $_[1] : $slots->{$slotName}; }, 'Class::Prototyped::FieldAccessor' ); if (defined $slotFilters) { foreach my $filter (@{ $slotFilters }) { $implementation = $filter->($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots); } } if (defined $slotAdvisories) { foreach my $advisory (@{ $slotAdvisories }) { $advisory->($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots); } } if ($slotAttribs->{overload}) { eval "package $package; use overload '$slotName' => \$implementation, fallback => 1; bless \$object, \$package;"; Carp::croak("Eval failed while defining overload\n" . "operation: \"$slotName\" error: $@") if $@; } else { no strict 'refs'; local $^W = 0; # suppress redefining messages. *{"$package\::$slotName"} = $implementation; } push (@$otherOrder, $slotName); } $attribs->{$slotName} = $slotAttribs; $types->{$slotName} = $slotType; } return $mirror; } sub addSlots { my $mirror = shift; $mirror->addParsedSlots( $mirror->addSlotsParser(@_) ); } *addSlot = \&addSlots; # alias addSlot to addSlots # $obj->reflect->deleteSlots( name [, name [...]] ); sub deleteSlots { my $mirror = shift; my (@deleteSlots) = @_; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; foreach my $slot (@deleteSlots) { $slot = substr($slot, 0, -1) if substr($slot, -2) eq '**'; $slot = substr($slot, 0, -1) if substr($slot, -1) eq '!'; next if !exists($slots->{$slot}); my $value = $slots->{$slot}; if (substr($slot, -1) eq '*') { # parent slot my $index = 0; 1 while ($parentOrder->[$index] ne $slot and $index++ < @$parentOrder); if ($index < @$parentOrder) { splice(@$parentOrder, $index, 1); splice(@$isa, $index, 1); { #Defends against ISA caching problems no strict 'refs'; delete ${"$package\::"}{'::ISA::CACHE::'}; @$isa=@$isa; } } else { # not found if (!$Class::Prototyped::Mirror::ending) { Carp::cluck "couldn't find $slot in $package\n"; $DB::single = 1; } } if (defined($value)) { my $parentPackage = ref($value); if (substr($parentPackage, 0, PREFIX_LENGTH) eq PREFIX) { delete ($Class::Prototyped::Mirror::parents{$package}->{$slot} ); } } else { if (!$Class::Prototyped::Mirror::ending) { Carp::cluck "slot undef for $slot in $package\n"; $DB::single = 1; } } } else { if (exists($Class::Prototyped::overloadable_symbols{$slot})) { Carp::croak( "Perl segfaults when the last overload is removed. Boom!\n") if (1 == grep { exists($Class::Prototyped::overloadable_symbols{$_}); } keys(%$slots)); eval "package $package; no overload '$slot'; bless {}, \$package;" ; # dummy bless so that overloading works. Carp::croak("Eval failed while removing overload\n" . "operation: \"$slot\" error: $@") if $@; } else { # we have a method by that name; delete it no strict 'refs'; my $name = "$package\::$slot"; # save the glob... local *old = *{$name}; # and restore everything else local *new; foreach my $type (qw(HASH IO FORMAT SCALAR ARRAY)) { my $elem = *old{$type}; next if !defined($elem); *new = $elem; } *{$name} = *new; } @$otherOrder = grep { $_ ne $slot } @$otherOrder; } delete $slots->{$slot}; # and delete the data/sub ref delete $types->{$slot}; delete $attribs->{$slot}; } return $mirror; } *deleteSlot = \&deleteSlots; # alias deleteSlot to deleteSlots sub super_slow { return shift->super_fast(@_) if ((caller(1))[0] eq 'Class::Prototyped::Mirror::SUPER'); return shift->super_fast(@_) if ((caller(2))[0] eq 'Class::Prototyped::Mirror::SUPER'); Carp::croak( "attempt to call super on a method that was defined without !\n" . "method: " . $_[1]); } *super = \&super_slow unless defined(*super{CODE}); sub super_fast { my $mirror = shift; my $message = shift; $message or Carp::croak("you have to pass the method name to super"); my $object = ${ $mirror }; my (@isa); { no strict 'refs'; @isa = @{ $Class::Prototyped::Mirror::SUPER::package . '::ISA' }; } my $method; foreach my $parentPackage (@isa) { $method = UNIVERSAL::can($parentPackage, $message); last if $method; } $method or Carp::croak("could not find super in parents\nmessage: $message"); $method->($object, @_); } sub slotNames { my $mirror = shift; my $type = shift; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; my @slotNames = (@$parentOrder, @$otherOrder); if ($type) { @slotNames = grep { $types->{$_} eq $type } @slotNames; } return wantarray ? @slotNames : \@slotNames; } sub slotType { my $mirror = shift; my $slotName = shift; my $types = $mirror->_types; Carp::croak( "attempt to determine slotType for unknown slot\nslot: $slotName") unless exists $types->{$slotName}; return $types->{$slotName}; } # may return dups sub allSlotNames { my $mirror = shift; my $type = shift; my @slotNames; foreach my $parent ($mirror->withAllParents()) { my $mirror = Class::Prototyped::Mirror->new($parent); push (@slotNames, $mirror->slotNames($type)); } return wantarray ? @slotNames : \@slotNames; } sub parents { my $mirror = shift; my $object = $mirror->object; my $slots = $mirror->_slots; return map { $slots->{$_} } $mirror->slotNames('PARENT'); } sub allParents { my $mirror = shift; my $retval = shift || []; my $seen = shift || {}; foreach my $parent ($mirror->parents) { next if $seen->{$parent}++; push @$retval, $parent; my $mirror = Class::Prototyped::Mirror->new($parent); $mirror->allParents($retval, $seen); } return wantarray ? @$retval : $retval; } sub withAllParents { my $mirror = shift; my $object = $mirror->object; my $retval = [$object]; my $seen = { $object => 1 }; $mirror->allParents($retval, $seen); } # getSlot returns both the slotName and the slot in array context # so that it can append !'s to superable methods, so that getSlots does the # right thing, so that clone does the right thing. # However, in scalar context, it just returns the value. sub getSlot { my $mirror = shift; my $slot = shift; my $format = shift; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; my $value = ($slot ne 'self*') ? $slots->{$slot} : $mirror->object; return $value unless wantarray; $slot = [$slot, $types->{$slot}, %{$attribs->{$slot} || {}}]; if (!defined $format || $format eq 'default') { return ($slot, $value); } elsif ($format eq 'simple') { return ($slot->[0], $value); } elsif ($format eq 'rotated') { return ($slot->[0], { attribs => { @{$slot}[2..$#{$slot}] }, type => $slot->[1], value => $value } ); } } sub getSlots { my $mirror = shift; my $type = shift; my $format = shift; my @retval; if (defined $type || defined $format) { @retval = map { $mirror->getSlot($_, $format) } $mirror->slotNames($type); } else { my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; @retval = map { ([$_, $types->{$_}, %{$attribs->{$_} || {}}] => $slots->{$_}) } (@$parentOrder, @$otherOrder); } return wantarray ? @retval : \@retval; } sub promoteParents { my $mirror = shift; my (@newOrder) = @_; my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) = $mirror->_everything; my %seen; foreach my $slot (@newOrder) { $seen{$slot}++; if ($seen{$slot} > 1 || !exists($slots->{$slot})) { Carp::croak("promoteParents called with bad order list\nlist: @_"); } else { @{$parentOrder} = grep { $_ ne $slot } @{$parentOrder}; } } @{$parentOrder} = (@newOrder, @{$parentOrder}); @$isa = ((map { ref($slots->{$_}) ? ref($slots->{$_}) : $slots->{$_} } @{$parentOrder}), 'Class::Prototype'); # this is required to re-cache @ISA no strict 'refs'; delete ${"$package\::"}{'::ISA::CACHE::'}; @$isa=@$isa; } sub wrap { my $mirror = shift; my $class = $mirror->class || 'Class::Prototyped'; my $wrapped = $class->new; my $wrappedMirror = $wrapped->reflect; # add all the slots from the original object $wrappedMirror->addSlots($mirror->getSlots); # delete all my original slots # so that the wrapped gets called $mirror->deleteSlots($mirror->slotNames); $mirror->addSlots(@_, [qw(wrapped* promote)] => $wrapped); $mirror; } sub unwrap { my $mirror = shift; my $wrapped = $mirror->getSlot('wrapped*') or Carp::croak "unwrapping without a wrapped\n"; my $wrappedMirror = $wrapped->reflect; $mirror->deleteSlots($mirror->slotNames); $mirror->addSlots($wrappedMirror->getSlots); # $wrappedMirror->deleteSlots( $wrappedMirror->slotNames ); $mirror; } sub delegate { my $mirror = shift; while (my ($name, $value) = splice(@_, 0, 2)) { my @names = (UNIVERSAL::isa($name, 'ARRAY') ? @$name : $name); my @conflicts; foreach my $slotName (@names) { push (@conflicts, grep { $_ eq $slotName } $mirror->slotNames); } Carp::croak( "delegate would cause conflict with existing slots\n" . "pattern: " . join ('|', @names) . " , conflicting slots: " . join (', ', @conflicts)) if @conflicts; my $delegateMethod; if (UNIVERSAL::isa($value, 'ARRAY')) { $delegateMethod = $value->[1]; $value = $value->[0]; } my $delegate = $mirror->getSlot($value) || $value; Carp::croak("Can't delegate to a subroutine\nslot: $name") if (UNIVERSAL::isa($delegate, 'CODE')); foreach my $slotName (@names) { my $method = defined($delegateMethod) ? $delegateMethod : $slotName; $mirror->addSlot( $slotName => sub { shift; # discard original recipient $delegate->$method(@_); } ); } } } sub findImplementation { my $mirror = shift; my $slotName = shift; my $object = $mirror->object; UNIVERSAL::can($object, $slotName) or return; my $slots = $mirror->_slots; exists $slots->{$slotName} and return wantarray ? 'self*' : $object; foreach my $parentName ($mirror->slotNames('PARENT')) { my $mirror = Class::Prototyped::Mirror->new( scalar($mirror->getSlot($parentName))); if (wantarray) { my (@retval) = $mirror->findImplementation($slotName); scalar(@retval) and return ($parentName, @retval); } else { my $retval = $mirror->findImplementation($slotName); $retval and return $retval; } } Carp::croak("fatal error in findImplementation"); } # load the given file or package in the receiver's namespace # Note that no import is done. # Croaks on an eval error # # $mirror->include('Package'); # $mirror->include('File.pl'); # # $mirror->include('File.pl', 'thisObject'); # makes thisObject() return the object into which the include # is happening (as long as you don't change packages in the # included code) sub include { my $mirror = shift; my $name = shift; my $accessorName = shift; $name = "'$name'" if $name =~ /\.p[lm]$/i; my $object = $mirror->object; my $package = $mirror->package; my $text = "package $package;\n"; $text .= "*$package\::$accessorName = sub { \$object };\n" if defined($accessorName); # $text .= "sub $accessorName { \$object };\n" if defined($accessorName); $text .= "require $name;\n"; my $retval = eval $text; Carp::croak("include failed\npackage: $package include: $name error: $@") if $@; if (substr($name, -1) eq "'") { $mirror->_vivified_methods(0); $mirror->_autovivify_methods; } $mirror->deleteSlots($accessorName) if defined($accessorName); } 1; __END__ =head1 NAME C - Fast prototype-based OO programming in Perl =head1 SYNOPSIS use strict; use Class::Prototyped ':EZACCESS'; $, = ' '; $\ = "\n"; my $p = Class::Prototyped->new( field1 => 123, sub1 => sub { print "this is sub1 in p" }, sub2 => sub { print "this is sub2 in p" } ); $p->sub1; print $p->field1; $p->field1('something new'); print $p->field1; my $p2 = Class::Prototyped->new( 'parent*' => $p, field2 => 234, sub2 => sub { print "this is sub2 in p2" } ); $p2->sub1; $p2->sub2; print ref($p2), $p2->field1, $p2->field2; $p2->field1('and now for something different'); print ref($p2), $p2->field1; $p2->addSlots( sub1 => sub { print "this is sub1 in p2" } ); $p2->sub1; print ref($p2), "has slots", $p2->reflect->slotNames; $p2->reflect->include( 'xx.pl' ); # includes xx.pl in $p2's package print ref($p2), "has slots", $p2->reflect->slotNames; $p2->aa(); # calls aa from included file xx.pl $p2->deleteSlots('sub1'); $p2->sub1; =head1 DESCRIPTION This package provides for efficient and simple prototype-based programming in Perl. You can provide different subroutines for each object, and also have objects inherit their behavior and state from another object. The structure of an object is inspected and modified through I, which are created by calling C on an object or class that inherits from C. =head2 Installation instructions This module requires C to use the automated installation procedures. With C installed: Build.PL perl build test perl build install It can be installed under ActivePerl for Win32 by downloading the PPM from CPAN (the file has the extension C<.ppm.zip>). To install, download the C<.ppm.zip> file, uncompress it, and execute: ppm install Class-Prototyped.ppd The module can also be installed manually by copying C to C (along with C if you want it). =head1 WHEN TO USE THIS MODULE When I reach for C, it's generally because I really need it. When the cleanest way of solving a problem is for the code that uses a module to subclass from it, that is generally a sign that C would be of use. If you find yourself avoiding the problem by passing anonymous subroutines as parameters to the C method, that's another good sign that you should be using prototype based programming. If you find yourself storing anonymous subroutines in databases, configuration files, or text files, and then writing infrastructure to handle calling those anonymous subroutines, that's yet another sign. When you expect the people using your module to want to change the behavior, override subroutines, and so forth, that's a sign. =head1 CONCEPTS =head2 Slots C borrows very strongly from the language Self (see http://www.sun.com/research/self for more information). The core concept in Self is the concept of a slot. Think of slots as being entries in a hash, except that instead of just pointing to data, they can point to objects, code, or parent objects. So what happens when you send a message to an object (that is to say, you make a method call on the object)? First, Perl looks for that slot in the object. If it can't find that slot in the object, it searches for that slot in one of the object's parents (which we'll come back to later). Once it finds the slot, if the slot is a block of code, it evaluates the code and returns the return value. If the slot references data, it returns that data. If you assign to a data slot (through a method call), it modifies the data. Distinguishing data slots and method slots is easy - the latter are references to code blocks, the former are not. Distinguishing parent slots is not so easy, so instead a simple naming convention is used. If the name of the slot ends in an asterisk, the slot is a parent slot. If you have programmed in Self, this naming convention will feel very familiar. =head2 Reflecting In Self, to examine the structure of an object, you use a mirror. Just like using his shield as a mirror enabled Perseus to slay Medusa, holding up a mirror enables us to look upon an object's structure without name space collisions. Once you have a mirror, you can add and delete slots like so: my $cp = Class::Prototyped->new(); my $mirror = $cp->reflect(); $mirror->addSlots( field1 => 'foo', sub1 => sub { print "this is sub1 printing field1: '".$_[0]->field1."'\n"; }, ); $mirror->deleteSlot('sub1'); In addition, there is a more verbose syntax for C where the slot name is replaced by an anonymous array - this is most commonly used to control the slot attributes. $cp->reflect->addSlot( [qw(field1 FIELD)] => 'foo', [qw(sub1 METHOD)] => sub { print "hi there.\n"; }, ); Because the mirror methods C, C(C), C(C), and C(C) are called frequently on objects, there is an import keyword C<:EZACCESS> that adds methods to the object space that call the appropriate reflected variants. =head2 Slot Attributes Slot attributes allow the user to specify additional information and behavior relating to a specific slot in an extensible manner. For instance, one might want to mark a specific field slot as constant or to attach a description to a given slot. Slot attributes are divided up in two ways. The first is by the type of slot - C, C, or C. Some slot attributes apply to all three, some to just two, and some to only one. The second division is on the type of slot attribute: =over 4 =item implementor These are responsible for implementing the behavior of a slot. An example is a C slot with the attribute C. A slot is only allowed one implementor. All slot types have a default implementor. For C slots, it is a read-write scalar. For C slots, it is the passed anonymous subroutine. For C slots, C and C slot attributes don't really make sense. =item filter These filter access to the C. The quintessential example is the C attribute. When set, this increments a counter in C<$Class::Prototyped::Mirror::PROFILE::counts> every time the underlying C or C is accessed. Filter attributes can be stacked, so each attribute is assigned a rank with lower values being closer to the C and higher values being closer to the caller. =item advisory These slot attributes serve one of two purposes. They can be used to store information about the slot (i.e. C attributes), and they can be used to pass information to the C method (i.e. the C attribute, which can be used to promote a new C slot ahead of all the existing C slots). =back There is currently no formal interface for creating your own attributes - if you feel the need for new attributes, please contact the maintainer first to see if it might make sense to add the new attribute to C. If not, the contact might provide enough impetus to define a formal interface. The attributes are currently defined in C<$Class::Prototyped::Mirror::attributes>. Finally, see the C method for information about setting default attributes. This can be used, for instance, to turn on profiling everywhere. =head2 Classes vs. Objects In Self, everything is an object and there are no classes at all. Perl, for better or worse, has a class system based on packages. We decided that it would be better not to throw out the conventional way of structuring inheritance hierarchies, so in C, classes are first-class objects. However, objects are not first-class classes. To understand this dichotomy, we need to understand that there is a difference between the way "classes" and the way "objects" are expected to behave. The central difference is that "classes" are expected to persist whether or not that are any references to them. If you create a class, the class exists whether or not it appears in anyone's C<@ISA> and whether or not there are any objects in it. Once a class is created, it persists until the program terminates. Objects, on the other hand, should follow the normal behaviors of reference-counted destruction - once the number of references to them drops to zero, they should miraculously disappear - the memory they used needs to be returned to Perl, their C methods need to be called, and so forth. Since we don't require this behavior of classes, it's easy to have a way to get from a package name to an object - we simply stash the object that implements the class in C<$Class::Prototyped::Mirror::objects{$package}>. But we can't do this for objects, because if we do the object will persist forever because that reference will always exist. Weak references would solve this problem, but weak references are still considered alpha and unsupported (C<$WeakRef::VERSION = 0.01>), and we didn't want to make C dependent on such a module. So instead, we differentiate between classes and objects. In a nutshell, if an object has an explicit package name (I something other than the auto-generated one), it is considered to be a class, which means it persists even if the object goes out of scope. To create such an object, use the C method, like so (the encapsulating block exists solely to demonstrate that classes are not scoped): { my $object = Class::Prototyped->newPackage('MyClass', field => 1, double => sub {$_[0]->field*2} ); } print MyClass->double,"\n"; Notice that the class persists even though C<$object> goes out of scope. If C<$object> were created with an auto-generated package, that would not be true. Thus, for instance, it would be a B bad idea to add the package name of an object as a parent to another object - when the first object goes out of scope, the package will disappear, but the second object will still have it in it's C<@ISA>. Except for the crucial difference that you should B make use of the package name for an object for any purpose other than printing it to the screen, objects and classes are simply different ways of inspecting the same entity. To go from an object to a package, you can do one of the following: $package = ref($object); $package = $object->reflect->package; The two are equivalent, although the first is much faster. Just remember, if C<$object> is in an auto-generated package, don't do anything with that C<$package> but print it. To go from a package to an object, you do this: $object = $package->reflect->object; Note that C<$package> is simple the name of the package - the following code works perfectly: $object = MyClass->reflect->object; But keep in mind that C<$package> has to be a class, not an auto-generated package name for an object. =head2 Class Manipulation This lets us have tons of fun manipulating classes at run time. For instance, if you wanted to add, at run-time, a new method to the C class? Assuming that the C inherits from C or that you have specified C<:REFLECT> on the C call, you simply write: MyClass->reflect->addSlot(myMethod => sub {print "Hi there\n"}); If you want to access a class that doesn't inherit from C, and you want to avoid specifying C<:REFLECT> (which adds C to the C package), you can make the call like so: my $mirror = Class::Prototyped::Mirror->new('MyClass'); $mirror->addSlot(myMethod => sub {print "Hi there\n"}); Just as you can C objects, you can C classes that are derived from C. This creates a new object that has a copy of all of the slots that were defined in the class. Note that if you simply want to be able to use C on a class, calling C<< MyClass->reflect->object >> is the preferred approach. Even easier would be to use the C mirror method. The code that implements reflection on classes automatically creates slot names for package methods as well as parent slots for the entries in C<@ISA>. This means that you can code classes like you normally do - by doing the inheritance in C<@ISA> and writing package methods. If you manually add subroutines to a package at run-time and want the slot information updated properly (although this really should be done via the C mechanism, but maybe you're twisted:), you should do something like: $package->reflect->_vivified_methods(0); $package->reflect->_autovivify_methods; =head2 Parent Slots Adding parent slots is no different than adding normal slots - the naming scheme takes care of differentiating. Thus, to add C<$foo> as a parent to C<$bar>, you write: $bar->reflect->addSlot('fooParent*' => $foo); However, keeping with our concept of classes as first class objects, you can also write the following: $bar->reflect->addSlot('mixIn*' => 'MyMix::Class'); It will automatically require the module in the namespace of C<$bar> and make the module a parent of the object. This can load a module from disk if needed. If you're lazy, you can add parents without names like so: $bar->reflect->addSlot('*' => $foo); The slots will be automatically named for the package passed in - in the case of C objects, the package is of the form C. In the following example, the parent slot will be named C. $bar->reflect->addSlot('*' => 'MyMix::Class'); Parent slots are added to the inheritance hierarchy in the order that they were added. Thus, in the following code, slots that don't exist in C<$foo> are looked up in C<$fred> (and all of its parent slots) before being looked up in C<$jill>. $foo->reflect->addSlots('fred*' => $fred, 'jill*' => $jill); Note that C and C are identical - the variants exist only because it looks ugly to add a single slot by calling C. If you need to reorder the parent slots on an object, look at C. That said, there's a shortcut for prepending a slot to the inheritance hierarchy. Simply define C<'promote'> as a slot attribute using the extended slot syntax. Finally, in keeping with our principle that classes are first-class object, the inheritance hierarchy of classes can be modified through C and C, just like it can for objects. The following code adds the C<$foo> object as a parent of the C class, prepending it to the inheritance hierarchy: MyClass->reflect->addSlots([qw(foo* promote)] => $foo); =head2 Operator Overloading In C, you do operator overloading by adding slots with the right name. First, when you do the C on C, make sure to pass in C<:OVERLOAD> so that the operator overloading support is enabled. Then simply pass the desired methods in as part of the object creation like so: $foo = Class::Prototyped->new( value => 3, '""' => sub { my $self = shift; $self->value( $self->value + 1 ) }, ); This creates an object that increments its field C by one and returns that incremented value whenever it is stringified. Since there is no way to find out which operators are overloaded, if you add overloading to a I through the use of C, that behavior will not show up as slots when reflecting on the class. However, C B work for adding operator overloading to classes. Thus, the following code does what is expected: Class::Prototyped->newPackage('MyClass'); MyClass->reflect->addSlots( '""' => sub { my $self = shift; $self->value( $self->value + 1 ) }, ); $foo = MyClass->new( value => 2 ); print $foo, "\n"; =head2 Object Class The special parent slot C is used to indicate object class. When you create C objects by calling C<< Class::Prototyped->new() >>, the C slot is B set. If, however, you create objects by calling C on a class or object that inherits from C, the slot C points to the package name if C was called on a named class, or the object if C was called on an object. The value of this slot can be returned quite easily like so: $foo->reflect->class; =head2 Calling Inherited Methods Methods (and fields) inherited from prototypes or classes are I generally available using the usual Perl C<< $self->SUPER::something() >> mechanism. The reason for this is that C is hardcoded to the package in which the subroutine (anonymous or otherwise) was defined. For the vast majority of programs, this will be C, and thus C will look in C<@main::ISA> (not a very useful place to look). To get around this, a very clever wrapper can be automatically placed around your subroutine that will automatically stash away the package to which the subroutine is attached. From within the subroutine, you can use the C mirror method to make an inherited call. However, because we'd rather not write code that attempts to guess as to whether or not the subroutine uses the C construct, you have to tell C that the subroutine needs to have this wrapper placed around it. To do this, simply use the extended C syntax (see the method description for more information) and pass in the slot attribute C<'superable'>. The following examples use the minimalist form of the extended syntax. For instance, the following code will work: use Class::Prototyped; my $p1 = Class::Prototyped->new( method => sub { print "this is method in p1\n" }, ); my $p2 = Class::Prototyped->new( '*' => $p1, [qw(method superable)]' => sub { print "this is method in p2 calling method in p1: "; $_[0]->reflect->super('method'); }, ); To make things easier, if you specify C<:EZACCESS> during the import, C can be called directly on an object rather than through its mirror. The other thing of which you need to be aware is copying methods from one object to another. The proper way to do this is like so: $foo->reflect->addSlot($bar->reflect->getSlot('method')); When the C method is called in an array context, it returns both the complete format for the slot identifier and the slot. This ensures that slot attributes are passed along, including the C attribute. Finally, to help protect the code, the C method is smart enough to determine whether it was called within a wrapped subroutine. If it wasn't, it croaks indicating that the method should have had the C attribute set when it was added. If you wish to disable this checking (which will improve the performance of your code, of course, but could result in B hard to trace bugs if you haven't been careful), see the import option C<:SUPER_FAST>. =head1 PERFORMANCE NOTES It is important to be aware of where the boundaries of prototyped based programming lie, especially in a language like Perl that is not optimized for it. For instance, it might make sense to implement every field in a database as an object. Those field objects would in turn be attached to a record class. All of those might be implemented using C. However, it would be very inefficient if every record that got read from the database was stored in a C based object (unless, of course, you are storing code in the database). In that situation, it is generally good to choke off the prototype-based behavior for the individual record objects. For best performance, it is important to confine C to those portions of the code where behavior is mutable from outside of the module. See the documentation for the C method of C for more information about choking off C behavior. There are a number of performance hits when using C, relative to using more traditional OO code. B that these generally lie in the instantiation and creation of classes and objects and not in the actual use of them. The scripts in the C directory were designed for benchmarking some of this material. =head2 Class Instantiation The normal way of creating a class is like this: package Pack_123; sub a {"hi";} sub b {"hi";} sub c {"hi";} sub d {"hi";} sub e {"hi";} The most efficient way of doing that using "proper" C methodology looks like this: Class::Prototyped->newPackage("Pack_123"); push(@P_123::slots, a => sub {"hi";}); push(@P_123::slots, b => sub {"hi";}); push(@P_123::slots, c => sub {"hi";}); push(@P_123::slots, d => sub {"hi";}); push(@P_123::slots, e => sub {"hi";}); Pack_123->reflect->addSlots(@P_123::slots); This approach ensures that the new package gets the proper default attributes and that the slots are created through C, thus ensuring that default attributes are properly implemented. It avoids multiple calls to C<< ->reflect->addSlot >>, though, which improves performance. The idea behind pushing the slots onto an array is that it enables one to intersperse code with POD, since POD is not permitted inside of a single Perl statement. On a Pent 4 1.8GHz machine, the normal code runs in 120 usec, whereas the C code runs in around 640 usec, or over 5 times slower. A straight call to C with all five methods runs in around 510 usec. Code that creates the package and the mirror without adding slots runs in around 135 usec, so we're looking at an overhead of less than 100 usec per slot. In a situation where the "compile" time dominates the "execution" time (I'm using those terms loosely as much of what happens in C is technically execution time, but it is activity that traditionally would happen at compile time), C might prove to be too much overhead. On the otherhand, you may find that demand loading can cut much of that overhead and can be implemented less painfully than might otherwise be thought. =head2 Object Instantiation There is no need to even compare here. Blessing a hash into a class takes less than 2 usec. Creating a new C object takes at least 60 or 70 times longer. The trick is to avoid creating unnecessary C objects. If you know that all 10,000 database records are going to inherit all of their behavior from the parent class, there is no point in creating 10,000 packages and all the attendant overhead. The C method for C demonstrates how to ensure that those state objects are created as normal Perl objects. =head2 Method Calls The good news is that method calls are just as fast as normal Perl method calls, inherited or not. This is because the existing Perl OO machinery has been hijacked in C. The exception to this is if C slot attributes have been used, including C, C, and C. In that situation, the added overhead is that for a normal Perl subroutine call (which is faster than a method call because it is a static binding) =head2 Instance Variable Access The hash interface is not particularly fast, and neither is it good programming practice. Using the method interface to access fields is just as fast, however, as using normal getter/setter methods. =head1 IMPORT OPTIONS =over 4 =item C<:OVERLOAD> This configures the support in C for using operator overloading. =item C<:REFLECT> This defines C to return a mirror for any class. With a mirror, you can manipulate the class, adding or deleting methods, changing its inheritance hierarchy, etc. =item C<:EZACCESS> This adds the methods C, C, C, C, C, C, and C to C. This lets you write: $foo->addSlot(myMethod => sub {print "Hi there\n"}); instead of having to write: $foo->reflect->addSlot(myMethod => sub {print "Hi there\n"}); The other methods in C should be accessed through a mirror (otherwise you'll end up with way too much name space pollution for your objects:). Note that it is bad form for published modules to use C<:EZACCESS> as you are polluting everyone else's namespace as well. If you B want C<:EZACCESS> for code you plan to publish, contact the maintainer and we'll see what we can about creating a variant of C<:EZACCESS> that adds the shortcut methods to a single class. Note that using C<:EZACCESS> to do C<< $obj->addSlot() >> is actually slower than doing C<< $obj->reflect->addSlot() >>. =item C<:SUPER_FAST> Switches over to the fast version of C that doesn't check to see whether slots that use inherited calls were defined as superable. =item C<:NEW_MAIN> Creates a C function in C that creates new C objects. Thus, you can write code like: use Class::Prototyped qw(:NEW_MAIN :EZACCESS); my $foo = new(say_hi => sub {print "Hi!\n";}); $foo->say_hi; =item C<:TIED_INTERFACE> This is no longer supported. Sorry for the very short notice - if you have a specific need, please let me know and I will discuss your needs with you and determine whether they can be addressed in a manner that doesn't require you to rewrite your code, but still allows others to make use of less global control over the tied interfaces used. See C for the preferred way of doing this. =back =head1 C Methods =head2 new() - Construct a new C object. A new object is created. If this is called on a class or object that inherits from C, and C is not being passed as a slot in the argument list, the slot C will be the first element in the inheritance list. When called on named classes, either via the package name or via the object (i.e. C<< MyPackage->reflect->object() >>), C is set to the package name. When called on an object, C is set to the object on which C was called. The passed arguments are handed off to C. Note that C calls C, so if you want to override C, but want to ensure that your changes are applicable to C, C, and C, you may wish to override C. For instance, the following will define a new C object with two method slots and one field slot: my $foo = Class::Prototyped->new( field1 => 123, sub1 => sub { print "this is sub1 in foo" }, sub2 => sub { print "this is sub2 in foo" }, ); The following will create a new C object with one field slot and with the parent object C<$bar> at the beginning of the inheritance hierarchy (just before C, which points to C): my $foo = MyClass->new( field1 => 123, [qw(bar* promote)] => $bar, ); The following will create a new object that inherits behavior from C<$bar> with one field slot, C, and one parent slot, C, that points to C<$bar>. my $foo = $bar->new( field1 => 123, ); If you want to create normal Perl objects as child objects of a C class in order to improve performance, implement your own standard Perl C method: Class::Prototyped->newPackage('MyClass'); MyClass->reflect->addSlot( new => sub { my $class = shift; my $self = {}; bless $self, $class; return $self; } ); It is still safe to use C<< $obj->reflect->super() >> in code that runs on such an object. All other reflection will automatically return the same results as inspecting the class to which the object belongs. =head2 newPackage() - Construct a new C object in a specific package. Just like C, but instead of creating the new object with an arbitrary package name (actually, not entirely arbitrary - it's generally based on the hash memory address), the first argument is used as the name of the package. This creates a named class. The same behavioral rules for C described above for C apply to C (in fact, C calls C). If the package name is already in use, this method will croak. =head2 clone() - Duplicate me Duplicates an existing object or class and allows you to add or override slots. The slot definition is the same as in B. my $p2 = $p1->clone( sub1 => sub { print "this is sub1 in p2" }, ); It calls C to create the new object*, so if you have overridden C, you should contemplate overriding C in order to ensure that behavioral changes made to C that would be applicable to C are implemented. Or simply override C. =head2 clonePackage() Just like C, but instead of creating the new object with an arbitrary package name (actually, not entirely arbitrary - it's generally based on the hash memory address), the first argument is used as the name of the package. This creates a named class. If the package name is already in use, this method will croak. =head2 newCore() This implements the core functionality involved in creating a new object. The first passed parameter will be the name of the caller - either C, C, C, or C. The second parameter is the name of the package if applicable (i.e. for C and C) calls, C if inapplicable. The remainder of the parameters are any slots to be added to the newly created object/package. If called with C or C, the C slot will be prepended to the slot list if applicable. If called with C or C, all slots on the receiver will be prepended to the slot list. If you wish to add behavior to object instantiation that needs to be present in all four of the instantiators (i.e. instance tracking), it may make sense to override C so that you implement the code in only one place. =head2 reflect() - Return a mirror for the object or class The structure of an object is modified by using a mirror. This is the equivalent of calling: Class::Prototyped::Mirror->new($foo); =head2 destroy() - The destroy method for an object You should never need to call this method. However, you may want to override it. Because we had to directly specify C for every object in order to allow safe destruction during global destruction time when objects may have already destroyed packages in their C<@ISA>, we had to hook C for every object. To allow the C behavior to be overridden, users should specify a C method for their objects (by adding the slot), which will automatically be called by the C method after the C<@ISA> has been cleaned up. This method should be defined to allow inherited method calls (I should use "C<[qw(destroy superable)]>" to define the method) and should call C<< $self->reflect->super('destroy'); >> at some point in the code. Here is a quick overview of the default destruction behavior for objects: =over 4 =item * C is called because it is linked into the package for all objects at instantiation time =item * All no longer existent entries are stripped from C<@ISA> =item * The inheritance hierarchy is searched for a C method that is not C. This C method is stashed away for a later call. =item * The inheritance hierarchy is searched for a C method and it is called. Note that the C method, which will either be called directly because it shows up in the inheritance hierarchy or will be called indirectly through calls to C<< $self->reflect->super('destroy'); >>, will delete all non-parent slots from the object. It leaves parent slots alone because the destructors for the parent slots should not be called until such time as the destruction of the object in question is complete (otherwise inherited destructors might still be executing, even though the object to which they belong has already been destroyed). This means that the destructors for objects referenced in non-parent slots may be called, temporarily interrupting the execution sequence in C. =item * The previously stashed C method is called. =item * The parent slots for the object are finally removed, thus enabling the destructors for any objects referenced in those parent slots to run. =item * Final C specific cleanup is run. =back =head1 C Methods These are the methods you can call on the mirror returned from a C call. If you specify C<:EZACCESS> in the C line, C, C, C, C, C, C, and C will be callable on C objects as well. =head2 new() - Creates a new C object Normally called via the C method, this can be called directly to avoid using the C<:REFLECT> import option for reflecting on non C based classes. =head2 autoloadCall() If you add an C slot to an object, you will need to get the name of the subroutine being called. C returns the name of the subroutine, with the package name stripped off. =head2 package() - Returns the name of the package for the object =head2 object() - Returns the object itself =head2 class() - Returns the C slot for the underlying object =head2 dump() - Returns a Data::Dumper string representing the object =head2 addSlot() - An alias for C =head2 addSlots() - Add or replace slot definitions Allows you to add or replace slot definitions in the receiver. $p->reflect->addSlots( fred => 'this is fred', doSomething => sub { print 'doing something with ' . $_[1] }, ); $p->doSomething( $p->fred ); In addition to the simple form, there is an extended syntax for specifying the slot. In place of the slotname, pass an array reference composed like so: C<< addSlots( [$slotName, $slotType, %slotAttributes] => $slotValue ); >> C<$slotName> is simply the name of the slot, including the trailing C<*> if it is a parent slot. C<$slotType> should be C<'FIELD'>, C<'METHOD'>, or C<'PARENT'>. C<%slotAttributes> should be a list of attribute/value pairs. It is common to use qw() to reduce the amount of typing: $p->reflect->addSlot( [qw(bar FIELD)] => "this is a field", ); $p->reflect->addSlot( [qw(bar FIELD constant 1)] => "this is a constant field", ); $p->reflect->addSlot( [qw(foo METHOD)] => sub { print "normal method.\n"; }, ); $p->reflect->addSlot( [qw(foo METHOD superable 1)] => sub { print "superable method.\n"; }, ); $p->reflect->addSlot( [qw(parent* PARENT)] => $parent, ); $p->reflect->addSlot( [qw(parent2* PARENT promote 1)] => $parent2, ); To make using the extended syntax a bit less cumbersome, however, the following shortcuts are allowed: =over 4 =item * C<$slotType> can be omitted. In this case, the slot's type will be determined by inspecting the slot's name (to determine if it is a parent slot) and the slot's value (to determine whether it is a field or method slot). The C<$slotType> value can, however, be used to supply a reference to a code object as the value for a field slot. Note that this means that C, C, and C are not legal attribute names (since this would make parsing difficult). =item * If there is only one attribute and if the value is C<1>, then the value can be omitted. =back Using both of the above contractions, the following are valid short forms for the extended syntax: $p->reflect->addSlot( [qw(bar constant)] => "this is a constant field", ); $p->reflect->addSlot( [qw(foo superable)] => sub { print "superable method.\n"; }, ); $p->reflect->addSlot( [qw(parent2* promote)] => $parent2, ); The currently defined slot attributes are as follows: =over =item C Slots =over =item C (C) When true, this defines the field slot as constant, disabling the ability to modify it using the C<< $object->field($newValue) >> syntax. The value may still be modified using the hash syntax (i.e. C<< $object->{field} = $newValue >>). This is mostly useful if you have an object method call that takes parameters, but you wish to replace it on a given object with a hard-coded value by using a field (which makes inspecting the value of the slot through C much easier than if you use a C slot to return the constant, since code objects are opaque). =item C (C, rank 50) The passed value for the C slot should be a subroutine that returns the desired value. Upon the first access, the subroutine will be called, the return value hard-coded into the object by adding the slot (including all otherwise specified attributes), and the value then returned. Useful for implementing constant slots that are costly to initialize, especially those that return lists of C objects! =item C (C, rank 80) If C is set to 1, increments C<< $Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName} >> everytime the slot is accessed. If C is set to 2, increments C<< $Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}->{$caller} >> everytime the slot is accessed, where C<$caller> is C<"$file ($line)">. =item C (C, rank 90) If the field specifies a reference to an array and the call is in list context, dereferences the array and returns a list of values. =item C (C) Can be used to specify a description. No real support for this yet beyond that! =back =item C Slots =over =item C (C, rank 10) When true, this enables the C<< $self->reflect->super( . . . ) >> calls for this method slot. =item C (C, rank 90) See C slots for explanation. =item C (C) Set automatically for methods that implement operator overloading. =item C (C) See C slots for explanation. =back =item C Slots =over =item C (C) When true, this parent slot is promoted ahead of any other parent slots on the object. This attribute is ephemeral - it is not returned by calls to C. =item C (C) See C slots for explanation. =back =back =head2 deleteSlot() - An alias for deleteSlots =head2 deleteSlots() - Delete one or more of the receiver's slots by name This will let you delete existing slots in the receiver. If those slots were defined in the receiver's inheritance hierarchy, those inherited definitions will now be available. my $p1 = Class::Prototyped->new( field1 => 123, sub1 => sub { print "this is sub1 in p1" }, sub2 => sub { print "this is sub2 in p1" } ); my $p2 = Class::Prototyped->new( 'parent*' => $p1, sub1 => sub { print "this is sub1 in p2" }, ); $p2->sub1; # calls $p2.sub1 $p2->reflect->deleteSlots('sub1'); $p2->sub1; # calls $p1.sub1 $p2->reflect->deleteSlots('sub1'); $p2->sub1; # still calls $p1.sub1 =head2 super() - Call a method defined in a parent The call to a method defined on a parent that is obscured by the current one looks like so: $self->reflect->super('method_name', @params); =head2 slotNames() - Returns a list of all the slot names This is passed an optional type parameter. If specified, it should be one of C<'FIELD'>, C<'METHOD'>, or C<'PARENT'>. For instance, the following will print out a list of all slots of an object: print join(', ', $obj->reflect->slotNames)."\n"; The following would print out a list of all field slots: print join(', ', $obj->reflect->slotNames('FIELD')."\n"; The parent slot names are returned in the same order for which inheritance is done. =head2 slotType() - Given a slot name, determines the type This returns C<'FIELD'>, C<'METHOD'>, or C<'PARENT'>. It croaks if the slot is not defined for that object. =head2 parents() - Returns a list of all parents Returns a list of all parent object (or package names) for this object. =head2 allParents() - Returns a list of all parents in the hierarchy Returns a list of all parent objects (or package names) in the object's hierarchy. =head2 withAllParents() - Same as above, but includes self in the list =head2 allSlotNames() - Returns a list of all slot names defined for the entire inheritance hierarchy Note that this will return duplicate slot names if inherited slots are obscured. =head2 getSlot() - Returns the requested slot When called in scalar context, this returns the thing in the slot. When called in list context, it returns both the complete form of the extended syntax for specifying a slot name and the thing in the slot. There is an optional parameter that can be used to modify the format of the return value in list context. The allowable values are: =over =item * C<'default'> - the extended slot syntax and the slot value are returned =item * C<'simple'> - the slot name and the slot value are returned. Note that in this mode, there is no access to any attributes the slot may have =item * C<'rotated'> - the slot name and the following hash are returned like so: $slotName => { attribs => %slotAttribs, type => $slotType, value => $slotValue }, =back The latter two options are quite useful when used in conjunction with the C method. =head2 getSlots() - Returns a list of all the slots This returns a list of extended syntax slot specifiers and their values ready for sending to C. It takes first the optional parameter passed to C which specifies the type of slot (C<'FIELD'>, C<'METHOD'>, C<'PARENT'>, or C) and then the optional parameter passed to C, which specifies the format for the return value. If the latter is C<'simple'>, the returned values can be passed to C, but any non-default slot attributes (i.e. C or C) will be lost. If the latter is C<'rotated'>, the returned values are completely inappropriate for passing to C. Both C<'simple'> and C<'rotated'> are appropriate for assigning the return values into a hash. For instance, to add all of the field slots in C<$bar> to C<$foo>: $foo->reflect->addSlots($bar->reflect->getSlots('FIELD')); To get a list of all of the slots in the C<'simple'> format: my %barSlots = $bar->reflect->getSlots(undef, 'simple'); To get a list of all of the superable method slots in the C<'rotated'> format: my %barMethods = $bar->reflect->getSlots('METHOD', 'rotated'); foreach my $slotName (%barMethods) { delete $barMethods{$slotName} unless $barMethods{$slotName}->{attribs}->{superable}; } =head2 promoteParents() - This changes the ordering of the parent slots This expects a list of parent slot names. There should be no duplicates and all of the parent slot names should be already existing parent slots on the object. These parent slots will be moved forward in the hierarchy in the order that they are passed. Unspecified parent slots will retain their current positions relative to other unspecified parent slots, but as a group they will be moved to the end of the hierarchy. =head2 tiedInterfacePackage() - This specifies the tied interface package This allows you to specify the sort of tied interface you wish to offer when code accesses the object as a hash reference. If no parameter is passed, this will return the current tied interface package active for the object. If a parameter is passed, it should specify either the package name or an alias. The currently known aliases are: =over 4 =item default This specifies C as the tie class. The default behavior is to allow access to existing fields, but attempts to create fields, access methods, or delete slots will croak. This is the tie class used by C (unless you do something very naughty and call C<< Class::Prototyped->reflect->tiedInterfacePackage($not_default) >>), and as such is the fallback behavior for classes and objects if they don't get a different value from their inheritance. =item autovivify This specifies C as the tie class. The behavior of this package allows access to existing fields, will automatically create field slots if they don't exist, and will allow deletion of field slots. Attempts to access or delete method or parent slots will croak. =back Calls to C and C will use the tied interface in use on the existing object/package. When C is called for the first time on a class package, it will use the tied interface of its first parent class (i.e. C<$ISA[0]>). If that package has not yet had C called on it, it will check its parent, and so on and so forth. If none of the packages in the primary inheritance fork have been reflected upon, the value for C will be used, which should be C. =head2 defaultAttributes() - get and set default attributes This isn't particularly pretty. The general syntax looks something like: my $temp = MyClass->reflect->defaultAttributes; $temp->{METHOD}->{superable} = 1; MyClass->reflect->defaultAttributes($temp); The return value from C is a hash with the keys C<'FIELD'>, C<'METHOD'>, and C<'PARENT'>. The values are either C or hash references consisting of the attributes and their default values. Modify the data structure as desired and pass it back to C to change the default attributes for that object or class. Note that default attributes are not inherited dynamically - the inheritance occurs when a new object is created, but from that point on changes to a parent object are not inherited by the child. Global changes can be effected by modifying the C for C in a sufficiently early C block. Note that making global changes like this is C recommended for production modules as it may interfere with other modules that rely upon C. =head2 wrap() =head2 unwrap() =head2 delegate() delegate name => slot name can be string, regex, or array of same. slot can be slot name, or object, or 2-element array with slot name or object and method name. You can delegate to a parent. =head2 include() - include a package or external file You can C an arbitrary file in the namespace of an object or class without adding to the parents using C : $foo->include( 'xx.pl' ); will include whatever is in xx.pl. Likewise for modules: $foo->include( 'MyModule' ); will search along your C<@INC> path for C and include it. You can specify a second parameter that will be the name of a subroutine that you can use in your included code to refer to the object into which the code is being included (as long as you don't change packages in the included code). The subroutine will be removed after the include, so don't call it from any subroutines defined in the included code. If you have the following in C: sub b {'xxx.b'} sub c { return thisObject(); } # DON'T DO THIS! thisObject()->reflect->addSlots( 'parent*' => 'A', d => 'added.d', e => sub {'xxx.e'}, ); And you include it using: $mirror->include('File.pl', 'thisObject'); Then the C will work fine, but if sub C is called, it won't find C. =head1 AUTHOR Written by Ned Konz, perl@bike-nomad.com and Toby Ovod-Everett, toby@ovod-everett.org. 5.005_03 porting by chromatic. Toby Ovod-Everett is currently maintaining the package. =head1 LICENSE Copyright 2001-2004 Ned Konz and Toby Ovod-Everett. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L L L =cut Class-Prototyped-1.16/examples/0000755000175000017500000000000014674671765015236 5ustar tobytobyClass-Prototyped-1.16/examples/graphtest.pl0000444000175000017500000000072514674671765017576 0ustar tobytobyuse Class::Prototyped qw(:EZACCESS); use Class::Prototyped::Graph; package A; sub aa { } package main; my $p1 = Class::Prototyped->new( name => 'p1', '*' => 'A' ); my $p2 = Class::Prototyped->new( name => 'p2', '*' => $p1 ); my $p3 = Class::Prototyped->new( name => 'p3', '*' => $p2, '*' => $p1, '*' => 'A' ); my $p4 = Class::Prototyped->new( name => 'p4', '*' => $p3, '*' => $p1 ); Class::Prototyped::Mirror::graph( 'name', $p4 ); print "output is in graph.png"; Class-Prototyped-1.16/examples/graph.png0000444000175000017500000000331014674671765017040 0ustar tobytoby‰PNG  IHDRȘ’vdšPLTEÿÿþÿÿÿ¿¿¿ßßß___ŸŸŸ???ÄÞj tRNS@æØfXIDATxœíœMoÜ6†ýÈE·ñ1L·G½ôè)zõ¶MÑã.ê¤×¤hî àC6Р?·ÒJ+ócHÉ!E±za öF¦ø˜9šy¥3ö?ÐÙÜÐÄs4Z¤8é9qÃÕ@r!Àï)T $®U ¤9C)çlиq:Ê* á¹IGY¤mÛ ÛN*€´ÕêS¤cVMØù!]ÃEtYÎéæ ™°³Cº1h†rvHE¾m‚d™ÒwÑ‘Ì×¹!½ @úg#Å|]!óË¿R\”3C"VHœªƒÜì~ò¬ê ßmß{ Ö¼ÀªrÃê‡1zM#ùÍ›?vÿð[û!qª r÷òíÃý8ÕÙÍÓOŒ}··§š »+´ãÜ6·º*«JÙ}}ùÀ´“USìÚä-ûÛqD¤ª‚|Å®o6ŸÙ½õˆHÕt?É/ßþ¼¿âÒv@¬æ†”/JþÕî#Û ñBþ¬Hy6B@MäxäéA6‘­“çëá•ñ¿ä]¥b+PD_z&ˆ¶k!$sWµ–>]ùÉÌâ¬O.| á“aÇYi^tÄÃÇÉÚËéXpf€?—IN÷G:åLý]•ìÔqúx’)ç<¨7Ì.GV*å,àìtyë)g€´úæ.É4Êòî϶c$Q‡Œ5¦Pæ€tíßñ}M ¤†ô¸SÆ#>À#…ôº“®¬ø0–Òç>Nµ#GSBúÜÇé7±-ÐAúÜÇ~ëHJ2HŸû˜&‘GIéq“=EIéqšæcš"‚t» ££tgÜHc(I =îcêG¯úÓAk€5œ$,á>VZ4u†“$%ÜÇŠ„º\ûÂI È"îcUÊyf£€,â>ÖÏù4`þ‡Ù( ‹¸U=e¦1³@–1æj-N©iÌÃl …œRÔÃleÜÇæi…³$÷Š²Œ1G>̶hHlwÑ؇ٲ@n!w:B†“éÀŸó·í‡‡€ÞD NfÉ¿tò<#‰'©!G‹õáA9DxrÎqB‡“ÔƒÅzÓÛ¬ÁC¸P”ÄŒ'©!‹õµøŒëÎÄq^|¤EñŒëûKíCo#"xˆ‹Bêîãé™°lÔ{j NÚ úX¬õáÅ7f4nžø ‚ ]÷qo±flKí>¬Ȉ—ÿ(é–ÞbýëÕ·òÂC’WªxÈ —ÿŒVÅ}Ü[¬__ü«4âïMˆ—ëïª?Ãa/ÿæß4›ûX:ÅéØs}¨¶éÙäÔ_Ž¦¾e>M ¨Y É —ÿt‹Üi—Ž,Ö™¢sróúÝÅ2äå?Çu|ŠT$+ ”%÷ÑKi÷ ñýÝ dÀËƭꉗ† Þ öìk$º£“¿ñiˆó¿I9?S;›ñ` ï\o³¿çJnsØAÔ¦Åé 8ù‰Ì—Àˆ,pÑJÓè^×!·^HT¾ÄŠhi £-®ûÍK½Æý$"_âBd¹ß"xlo¸ùí¨ÆßwoºËRN ™¾ÄƒÈCÂPI+Í©'JŸÅýåž©«‘‘ãñæKP·±™Þì),—»œÍÈÖQ•ßÈ3V®Üˆ°|?ÈÈ»’V¦è¶ OòGZ×Ô«qøåé»DB¤·ä«CŸ:f-d¦ò›]È^PUkÆÊ ü¢TŸ¬’-Z!•æZ Ã{x –ÏKmdÅmé]f˜ ÌÀ±ü¦A‚áöþ˜îbŽ”ã9–ßtHGZÔy¯eë ”ßÊ Ê»(¿•”A/X~+#¨R°üVF1U­Å)®>¹0ÅVš¥xÏÀ‚”âþXŒ’| 8; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; my $p1 = new( a => 2, b => sub {'b'} ); ok( scalar(Class::Prototyped->reflect->_defaults), scalar($p1->reflect->_defaults) ); ok( scalar($p1->reflect->_defaults) ne scalar($p1->reflect->defaultAttributes) ); { my $temp = Data::Dumper->Dump([$p1->reflect->_defaults, $p1->reflect->_defaults]); ok( $temp =~ s/\$VAR1//g, 2); } { my $temp = Data::Dumper->Dump([$p1->reflect->_defaults, $p1->reflect->defaultAttributes]); ok( $temp =~ s/\$VAR1//g, 1); $temp = $p1->reflect->defaultAttributes; $temp->{METHOD}->{superable} = 1; $p1->reflect->defaultAttributes($temp); ok( scalar(Class::Prototyped->reflect->_defaults) ne scalar($p1->reflect->_defaults) ); ok( Data::Dumper->Dump([Class::Prototyped->reflect->_defaults]), Data::Dumper->Dump([{ FIELD => undef, METHOD => undef, PARENT => undef }]) ); ok( Data::Dumper->Dump([$p1->reflect->_defaults]), Data::Dumper->Dump([{ FIELD => undef, METHOD => {superable => 1}, PARENT => undef }]) ); $p1->reflect->addSlot(c => sub {'c'}); ok( Data::Dumper->Dump([[$p1->reflect->getSlots(undef, 'rotated')]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {}, type => 'METHOD', value => sub { } }, c => { attribs => {superable => 1}, type => 'METHOD', value => sub { } } ]]) ); } Class-Prototyped-1.16/t/reflectAny.t0000444000175000017500000000167114674671765016147 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:REFLECT); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 5; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; package A; sub a {'A.a'} sub aa {'A.aa'} package B; @B::ISA = 'A'; sub aa {'B.aa'} sub b {'B.b'} package C; @C::ISA = qw(B A); sub aa {'C.aa'} sub c {'C.c'} package D; @D::ISA = qw(C C B B A A); sub aa {'D.aa'} sub d {'D.d'} package main; sub sorted { join('|', sort(@_)) } my $p = Class::Prototyped->new(); my $pm = $p->reflect; my $am = Class::Prototyped::reflect('A'); my $bm = Class::Prototyped::reflect('B'); my $cm = Class::Prototyped::reflect('C'); my $dm = Class::Prototyped::reflect('D'); my @a; ok( sorted( @a = $pm->slotNames), '' ); ok( sorted( @a = $am->slotNames), 'a|aa' ); ok( sorted( @a = $bm->slotNames), 'A*|aa|b' ); ok( sorted( @a = $cm->slotNames), 'A*|B*|aa|c' ); ok( sorted( @a = $dm->slotNames), 'A*|A1*|B*|B1*|C*|C1*|aa|d' ); # vim: ft=perl Class-Prototyped-1.16/t/tied.t0000444000175000017500000000645714674671765015007 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:NEW_MAIN); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 57; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; my $p1 = new( a => 2, b => sub {'b'} ); ok( $p1->a, 2 ); ok( $p1->{a}, 2 ); ok( $p1->a(3), 3 ); ok( $p1->{a}, 3 ); ok( $p1->a, 3 ); ok( $p1->{a} = 4, 4 ); ok( $p1->a, 4 ); ok( $p1->{a}, 4 ); ok( $p1->b, 'b' ); ok( !(defined(eval { $p1->{b} }))); ok( $@ =~ /^attempt to access METHOD slot through tied hash object interface/ ); ok( !(defined(eval { $p1->{b} = 'c' }))); ok( $@ =~ /^attempt to access METHOD slot through tied hash object interface/ ); ok( !(defined(eval { $p1->{c} }))); ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ ); ok( !(defined(eval { $p1->{c} = 'c' }))); ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ ); ok( !(defined(eval { %{$p1} = (a => 2) }))); ok( $@ =~ /^attempt to call CLEAR on the hash interface of a Class::Prototyped object/ ); ok( join('|', keys %{$p1}), 'a'); $p1->reflect->addSlot('parent*' => new( d => 5, e => sub {'e'})); ok( join('|', keys %{$p1}), 'parent*|a'); ok( $p1->d, 5); ok( !(defined(eval { $p1->{d} }))); ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ ); ok( $p1->reflect->getSlot('parent*')->{d} = 7, 7); ok( $p1->d, 7); my $p3 = $p1->clone; ok( $p1->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default'); ok( $p3->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default'); $p3->reflect->tiedInterfacePackage('autovivify'); ok( $p3->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::AutoVivify'); ok( $p1->reflect->getSlot('parent*')->{d} = 7, 7); ok( $p1->d, 7); ok( !(defined($p3->{d}))); ok( $p3->{d} = 4, 4 ); ok( $p3->d, 4 ); ok( $p3->b, 'b' ); ok( !(defined(eval { $p3->{b} }))); ok( $@ =~ /^attempt to access METHOD slot through tied hash object interface/ ); my $p4 = $p1->clone; ok( $p4->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default'); ok( !(defined(eval { $p4->{d} }))); ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ ); my $p5 = $p3->clone; ok( Class::Prototyped->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default'); ok( $p5->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::AutoVivify'); ok( (defined(eval { $p3->{d} }))); @Test::Default_A1::ISA = qw(Class::Prototyped); @Test::Default_A2::ISA = qw(Test::Default_A1); my $p6 = Test::Default_A2->new(c => 5); ok( $p6->c, 5 ); ok( $p6->{c}, 5); ok( $p6->{c} = 7, 7); ok( $p6->{c}, 7); ok( !(defined(eval { $p6->{d} }))); ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ ); @Test::Autovivify_A1::ISA = qw(Class::Prototyped); @Test::Autovivify_A2::ISA = qw(Test::Autovivify_A1); @Test::Autovivify_A3::ISA = qw(Test::Autovivify_A2); Test::Autovivify_A1->reflect->tiedInterfacePackage('autovivify'); my $p7 = Test::Autovivify_A3->new(c => 5); ok( $p7->c, 5 ); ok( $p7->{c}, 5); ok( $p7->{c} = 7, 7); ok( $p7->{c}, 7); ok( $p7->{d} = 4, 4 ); ok( (defined(eval { $p7->{d} }))); @Test::Default_B1::ISA = qw(Test::Default_A2 Test::Autovivify_A3); my $p8 = Test::Default_B1->new(); ok( !(defined(eval { $p8->{d} }))); ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ ); Class-Prototyped-1.16/t/extendedSyntax.t0000444000175000017500000001426514674671765017065 0ustar tobytobyuse strict; $^W++; use Class::Prototyped; use Data::Dumper; use Test; BEGIN { $|++; plan tests => 43; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; package main; my $p = Class::Prototyped->new(); $p->reflect->addSlot('field_1' => 'field_1'); $p->reflect->addSlot([qw(field_2)] => 'field_2'); $p->reflect->addSlot([qw(field_3 FIELD)] => 'field_3'); $p->reflect->addSlot([qw(field_4 constant)] => 'field_4'); $p->reflect->addSlot([qw(field_5 constant 1)] => 'field_5'); $p->reflect->addSlot([qw(field_6 FIELD constant)] => 'field_6'); $p->reflect->addSlot([qw(field_7 FIELD constant 1)] => 'field_7'); $p->reflect->addSlot('method_1' => sub { print "method_1.\n";}); $p->reflect->addSlot([qw(method_2)] => sub { print "method_2.\n";}); $p->reflect->addSlot([qw(method_3 METHOD)] => sub { print "method_3.\n";}); $p->reflect->addSlot([qw(method_4 superable)] => sub { print "method_4.\n";}); $p->reflect->addSlot([qw(method_5 superable 1)] => sub { print "method_5.\n";}); $p->reflect->addSlot([qw(method_6 METHOD superable)] => sub { print "method_6.\n";}); $p->reflect->addSlot([qw(method_7 METHOD superable 1)] => sub { print "method_7.\n";}); my %slots = $p->reflect->getSlots(undef, 'rotated'); ok( join('|', sort keys %slots), join('|', sort map {("field_$_", "method_$_")} (1..7)) ); foreach my $i (1..3) { ok( Data::Dumper->Dump([$slots{"field_$i"}]), Data::Dumper->Dump([{attribs => {}, value => "field_$i", type => 'FIELD'}]) ); ok( Data::Dumper->Dump([$slots{"method_$i"}]), Data::Dumper->Dump([{attribs => {}, value => sub {}, type => 'METHOD'}]) ); } foreach my $i (4..7) { ok( Data::Dumper->Dump([$slots{"field_$i"}]), Data::Dumper->Dump([{attribs => {constant => 1}, value => "field_$i", type => 'FIELD'}]) ); ok( Data::Dumper->Dump([$slots{"method_$i"}]), Data::Dumper->Dump([{attribs => {superable => 1}, value => sub {}, type => 'METHOD'}]) ); } my $q = $p->clone(); $p->reflect->addSlot('parent_1*' => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_1*)) ); $p->reflect->addSlot([qw(parent_2*)] => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_1* parent_2*)) ); $p->reflect->addSlot([qw(parent_3* PARENT)] => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_1* parent_2* parent_3*)) ); $p->reflect->addSlot([qw(parent_4* promote)] => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_4* parent_1* parent_2* parent_3*)) ); $p->reflect->addSlot([qw(parent_5* promote 1)] => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_5* parent_4* parent_1* parent_2* parent_3*)) ); $p->reflect->addSlot([qw(parent_6* PARENT promote)] => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_6* parent_5* parent_4* parent_1* parent_2* parent_3*)) ); $p->reflect->addSlot([qw(parent_7* PARENT promote 1)] => $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_7* parent_6* parent_5* parent_4* parent_1* parent_2* parent_3*)) ); %slots = $p->reflect->getSlots(undef, 'rotated'); ok( join('|', sort keys %slots), join('|', sort map {("field_$_", "method_$_", "parent_$_*")} (1..7)) ); foreach my $i (1..7) { ok( Data::Dumper->Dump([$slots{"parent_$i*"}]), Data::Dumper->Dump([{attribs => {}, value => $q, type => 'PARENT'}]) ); } $p->reflect->addSlot(['field_d', description => 'This is a friendly to use field!'], 'friendly'); $p->reflect->addSlot(['method_d', description => 'This is a friendly to use method!'], sub {}); $p->reflect->addSlot(['parent_d*', description => 'This is a friendly to use parent!'], $q); ok( join('|', $p->reflect->slotNames('PARENT')), join('|', qw(parent_7* parent_6* parent_5* parent_4* parent_1* parent_2* parent_3* parent_d*)) ); ok( Data::Dumper->Dump([[$p->reflect->getSlots(undef, 'rotated')]]), Data::Dumper->Dump([[ (map {("parent_$_*" => {attribs => {}, type => 'PARENT', value => $q})} qw(7 6 5 4 1 2 3)), ('parent_d*' => {attribs => {description => 'This is a friendly to use parent!'}, type => 'PARENT', value => $q}), (map {("field_$_" => {attribs => {}, type => 'FIELD', value => "field_$_"})} (1..3)), (map {("field_$_" => {attribs => {constant => 1}, type => 'FIELD', value => "field_$_"})} (4..7)), (map {("method_$_" => {attribs => {}, type => 'METHOD', value => scalar($p->reflect->getSlot("method_$_"))})} (1..3)), (map {("method_$_" => {attribs => {superable => 1}, type => 'METHOD', value => scalar($p->reflect->getSlot("method_$_"))})} (4..7)), (field_d => {attribs => {description => 'This is a friendly to use field!'}, type => 'FIELD', value => 'friendly'}), (method_d => {attribs => {description => 'This is a friendly to use method!'}, type => 'METHOD', value => sub {}}), ]]) ); my $r = $p->clone(); ok( Data::Dumper->Dump([[$p->reflect->getSlots(undef, 'rotated')]]), Data::Dumper->Dump([[$r->reflect->getSlots(undef, 'rotated')]]) ); eval { $p->reflect->addSlot([qw(field_fail superable)], 'val'); }; ok( $@ =~ /FIELD slots cannot have the 'superable' attribute/ ); eval { $p->reflect->addSlot([qw(field_fail promote)], 'val'); }; ok( $@ =~ /FIELD slots cannot have the 'promote' attribute/ ); eval { $p->reflect->addSlot([qw(method_fail constant)], sub {}); }; ok( $@ =~ /METHOD slots cannot have the 'constant' attribute/ ); eval { $p->reflect->addSlot([qw(method_fail promote)], sub {}); }; ok( $@ =~ /METHOD slots cannot have the 'promote' attribute/ ); eval { $p->reflect->addSlot([qw(method_fail METHOD)], 'hi there'); }; ok( $@ =~ /method slots have to have CODE refs as values/ ); eval { $p->reflect->addSlot([qw(parent_fail* constant)], $q); }; ok( $@ =~ /PARENT slots cannot have the 'constant' attribute/ ); eval { $p->reflect->addSlot([qw(parent_fail* superable)], $q); }; ok( $@ =~ /PARENT slots cannot have the 'superable' attribute/ ); eval { $p->reflect->addSlot([qw(parent_fail PARENT)], $q); }; ok( $@ =~ /slots should end in \* if and only if the type is parent/ ); eval { $p->reflect->addSlot([qw(parent_fail* FIELD)], $q); }; ok( $@ =~ /slots should end in \* if and only if the type is parent/ ); eval { $p->reflect->addSlot([qw(parent_fail* METHOD)], sub {}); }; ok( $@ =~ /slots should end in \* if and only if the type is parent/ ); Class-Prototyped-1.16/t/include.t0000444000175000017500000000165314674671765015476 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:REFLECT); use Data::Dumper; use Test; use IO::File; use lib '.'; BEGIN { $|++; plan tests => 18; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; package A; sub Aa { 'Aaa' } package main; my $p = Class::Prototyped->new(); my $pm = $p->reflect; ok( !defined( $p->can('b') ) ); ok( !defined( $p->can('c') ) ); ok( !defined( $p->can('d') ) ); ok( !defined( $p->can('e') ) ); ok( !defined( $p->can('thisObject') ) ); ok( ! $p->isa( 'A' ) ); ok( scalar( () = $pm->slotNames ), 0 ); $pm->include( 't/include_xxx.pl', 'thisObject' ); ok( defined( $p->can('b') ) ); ok( defined( $p->can('c') ) ); ok( defined( $p->can('d') ) ); ok( defined( $p->can('e') ) ); ok( !defined( $p->can('thisObject') ) ); ok( $p->b, 'xxx.b' ); ok( $p->isa( 'A' ) ); ok( $p->Aa, 'Aaa' ); ok( scalar( ( ) = $pm->slotNames ) == 5 ); ok( !defined( eval { $p->c } ) ); ok( $@ =~ /Undefined subroutine/ ); Class-Prototyped-1.16/t/wrap.t0000444000175000017500000000362614674671765015026 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:EZACCESS); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 11 } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; package main; my $record = ''; my ( $p1_name, $wrapped1_name, $wrapped2_name ); { # Make an object with functionality: my $p1 = Class::Prototyped->new( s1 => sub {'p1.s1'}, s2 => sub {'p1.s2'}, 'destroy!' => sub { $record .= "About to call super->('destroy') on $_[0].\n"; $_[0]->super('destroy'); $record .= "Finished super->('destroy') on $_[0].\n"; }, ); $p1_name = '' . ($p1); ok( $p1->s1, 'p1.s1' ); ok( $p1->s2, 'p1.s2' ); $p1->reflect->wrap( 's1!' => sub { my $self = shift; 'before.' . $self->super('s1') . '.after'; } ); $wrapped1_name = '' . ( $p1->reflect->getSlot('wrapped*') ); ok( $p1->s1, 'before.p1.s1.after' ); $p1->reflect->wrap( 's1!' => sub { my $self = shift; 'xx.' . $self->super('s1') . '.xx'; } ); $wrapped2_name = '' . ( $p1->reflect->getSlot('wrapped*') ); ok( $p1->s1, 'xx.before.p1.s1.after.xx' ); ok( $record, '' ); $p1->reflect->unwrap; ok( $record, <('destroy') on $wrapped2_name. Finished super->('destroy') on $wrapped2_name. END ok( $p1->s1, 'before.p1.s1.after' ); $record = ''; $p1->reflect->unwrap; ok( $record, <('destroy') on $wrapped1_name. Finished super->('destroy') on $wrapped1_name. END ok( $p1->s1, 'p1.s1' ); $p1->reflect->wrap( 's1!' => sub { my $self = shift; 'before.' . $self->super('s1') . '.after'; } ); $wrapped1_name = '' . ( $p1->reflect->getSlot('wrapped*') ); $record = ''; ok( $p1->s1, 'before.p1.s1.after' ); } ok( $record, <('destroy') on $p1_name. Finished super->('destroy') on $p1_name. About to call super->('destroy') on $wrapped1_name. Finished super->('destroy') on $wrapped1_name. END # vim: ft=perl Class-Prototyped-1.16/t/super.t0000444000175000017500000000572614674671765015216 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:REFLECT :EZACCESS :OVERLOAD); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 33 } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; my $p1 = Class::Prototyped->new( s1 => sub {'p1.s1'} ); my $p2 = Class::Prototyped->new( '*' => $p1, s1 => sub {'p2.s1'}, 's2!' => sub { shift->reflect->super('s1') }, ); my $p2a = $p2->clone(); my $p3 = Class::Prototyped->new( '*' => $p2, s1 => sub {'p3.s1'}, [qw(s2 superable)] => sub { shift->super('s1') }, [qw(s3 METHOD superable)] => sub { shift->super('s2') }, [qw(s4 METHOD superable 1)] => sub { join('+', $_[0]->s2, $_[0]->super('s1'), $_[0]->super('s2') ) }, [qw(s5 superable)] => sub { join('+', $_[0]->s2, $_[0]->super('s2'), $_[0]->super('s1') ) }, 's6' => sub { join('+', map {$_[0]->$_()} map {"s$_"} (1..5) ) }, ); my $p3a = $p3->clone(); ok( $p1->s1, 'p1.s1' ); ok( $p2->s1, 'p2.s1' ); ok( $p2->s2, 'p1.s1' ); ok( $p2a->s1, 'p2.s1' ); ok( $p2a->s2, 'p1.s1' ); ok( $p3->s1, 'p3.s1' ); ok( $p3->s2, 'p2.s1' ); ok( $p3->s3, 'p1.s1' ); ok( $p3->s4, 'p2.s1+p2.s1+p1.s1' ); ok( $p3->s5, 'p2.s1+p1.s1+p2.s1' ); ok( $p3->s6, 'p3.s1+p2.s1+p1.s1+p2.s1+p2.s1+p1.s1+p2.s1+p1.s1+p2.s1' ); ok( $p3a->s1, 'p3.s1' ); ok( $p3a->s2, 'p2.s1' ); ok( $p3a->s3, 'p1.s1' ); ok( $p3a->s4, 'p2.s1+p2.s1+p1.s1' ); ok( $p3a->s5, 'p2.s1+p1.s1+p2.s1' ); ok( $p3a->s6, 'p3.s1+p2.s1+p1.s1+p2.s1+p2.s1+p1.s1+p2.s1+p1.s1+p2.s1' ); package MyClass; @MyClass::ISA = qw(Class::Prototyped); MyClass->addSlots( 'new!' => sub { my $class = shift; my $self = $class->super('new'); $self->reflect->addSlots( value => $self->value()*2, @_ ); return $self; }, value => 2, foo => sub { $_[0] }, ); package main; my $p4 = MyClass->new(); ok( $p4->value, 4 ); MyClass->value(3); my $p5 = MyClass->new(); ok( $p4->value, 4 ); ok( $p5->value, 6 ); Class::Prototyped->newPackage('MyClass::Sub', '*' => 'MyClass', [qw(new superable)] => sub { my $class = shift; my $self = $class->super('new', @_); $self->value($self->value()+5); return $self; }, [qw(foo superable)] => sub { 'Supered: '.(shift->reflect->super('foo')); }, ); my $p6 = MyClass::Sub->new(); ok( $p4->value, 4 ); ok( $p5->value, 6 ); ok( $p6->value, 11); my $p7 = MyClass::Sub->new(value => 20); ok( $p7->value, 25); my $mcs_dump = Data::Dumper->Dump([MyClass::Sub->reflect->getSlots(undef, 'rotated')]); { my $np3 = bless {}, 'MyClass::Sub'; ok( $np3->foo, 'Supered: '.$np3 ); ok( Data::Dumper->Dump([$np3->reflect->getSlots(undef, 'rotated')]), $mcs_dump); } ok( Data::Dumper->Dump([MyClass::Sub->reflect->getSlots(undef, 'rotated')]), $mcs_dump); MyClass::Sub->clonePackage('MyClass::SubClone'); my $p8 = MyClass::Sub->new(); my $p9 = MyClass::SubClone->new(); ok( $p4->value, 4 ); ok( $p5->value, 6 ); ok( $p6->value, 11); ok( $p8->value, 11); ok( $p9->value, 11); my $mcsc_dump = Data::Dumper->Dump([MyClass::SubClone->reflect->getSlots(undef, 'rotated')]); ok($mcs_dump, $mcsc_dump); # vim: ft=perl Class-Prototyped-1.16/t/include_xxx.pl0000444000175000017500000000022614674671765016550 0ustar tobytobysub b { 'xxx.b' } sub c { return thisObject(); } thisObject()->reflect->addSlots( 'parent*' => 'A', d => 'added.d', e => sub { 'xxx.e' }, ); 1; Class-Prototyped-1.16/t/delegate.t0000444000175000017500000000267514674671765015632 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:EZACCESS :SUPER); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 14; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; package A; sub a { my $self = shift; (ref($self) ? $self->name : $self) . 'A.a' } package main; my $p1 = Class::Prototyped->new( name => 'p1', m1 => sub { $_[0]->name . ".m1" }, ); my $p2 = Class::Prototyped->new( name => 'p2', m2 => sub { $_[0]->name . ".m2" }, m2a => sub { $_[0]->name . ".m2a" }, ); my $p3 = Class::Prototyped->new( name => 'p3', 'parent*' => $p1, p2 => $p2, s1 => sub {}, ); ok( $p1->m1, 'p1.m1' ); ok( $p2->m2, 'p2.m2' ); ok( $p2->m2a, 'p2.m2a' ); ok( $p3->m1, 'p3.m1' ); # inheritance $p3->reflect->delegate( m1 => 'parent*', m2 => $p2, m2a => 'p2', m3 => [ $p1, 'm1' ], m3a => [ 'parent*', 'm1' ], m4 => [ $p2, 'm2' ], m4a => [ 'p2', 'm2a' ], ); ok( $p3->m1, 'p1.m1' ); # delegation ok( $p3->m2, 'p2.m2' ); ok( $p3->m3, 'p1.m1' ); ok( $p3->m3a, 'p1.m1' ); ok( $p3->m4, 'p2.m2' ); ok( $p3->m4a, 'p2.m2a' ); # detect exceptions eval { $p3->reflect->delegate( m9 => 's1' ) }; ok( $@ =~ /delegate to a subroutine/ ); eval { $p3->reflect->delegate( m1 => 'p1' ) }; ok( $@ =~ /conflict with existing/ ); my $p4 = Class::Prototyped->new( name => 'p4', 'parent*' => 'A', ); ok( $p4->a, 'p4A.a' ); $p4->reflect->delegate( 'b' => [ 'parent*', 'a' ] ); ok( $p4->b, 'AA.a' ); # vim: ft=perl Class-Prototyped-1.16/t/classReflect.t0000444000175000017500000000154114674671765016461 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:REFLECT); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 12; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; package A; sub a {'A.a'} package main; my $p = Class::Prototyped->new(); my $pm = $p->reflect; my $a = A->reflect; my @slotNames = $a->slotNames; ok( @slotNames, 1 ); ok( $slotNames[0], 'a' ); my @slots = $a->getSlots; ok( scalar @slots, 2 ); ok( $slots[0]->[0], 'a' ); ok( $slots[0]->[1], 'METHOD'); ok( $a->getSlot('a') == UNIVERSAL::can( 'A', 'a' ) ); $a->addSlots( 'bb' => sub {'A.bb'} ); @slotNames = $a->slotNames; ok( @slotNames, 2 ); my %slots = $a->getSlots(undef, 'simple'); ok( scalar keys %slots, 2 ); ok( defined( $slots{bb} ) ); ok( $a->getSlot('bb') == A->can('bb') ); ok( ref( $a->object ), 'A' ); ok( defined( UNIVERSAL::can( 'A', 'bb' ) ) ); # vim: ft=perl Class-Prototyped-1.16/t/constant.t0000444000175000017500000000154214674671765015701 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:NEW_MAIN); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 32; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; my $p1 = new( a => 2, [qw(b constant)] => 2); my $p2 = $p1->clone(); ok( $p1->a, 2 ); ok( $p1->{a}, 2 ); ok( $p1->a(3), 3 ); ok( $p1->{a}, 3 ); ok( $p1->a, 3 ); ok( $p1->{a} = 4, 4 ); ok( $p1->a, 4 ); ok( $p1->{a}, 4 ); ok( $p1->b, 2 ); ok( $p1->{b}, 2 ); ok( $p1->b(3), 2 ); ok( $p1->{b}, 2 ); ok( $p1->b, 2 ); ok( $p1->{b} = 4, 4 ); ok( $p1->b, 4 ); ok( $p1->{b}, 4 ); ok( $p2->a, 2 ); ok( $p2->{a}, 2 ); ok( $p2->a(3), 3 ); ok( $p2->{a}, 3 ); ok( $p2->a, 3 ); ok( $p2->{a} = 4, 4 ); ok( $p2->a, 4 ); ok( $p2->{a}, 4 ); ok( $p2->b, 2 ); ok( $p2->{b}, 2 ); ok( $p2->b(3), 2 ); ok( $p2->{b}, 2 ); ok( $p2->b, 2 ); ok( $p2->{b} = 4, 4 ); ok( $p2->b, 4 ); ok( $p2->{b}, 4 ); Class-Prototyped-1.16/t/destroy.t0000444000175000017500000003316714674671765015551 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:EZACCESS); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 12 } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; my $record = ''; package MyClass; @MyClass::ISA = qw(Class::Prototyped); sub DESTROY { $record .= "You are in MyClass::DESTROY for " . ref($_[0]) . "\n"; } package MyClass_Alt; @MyClass_Alt::ISA = qw(Class::Prototyped); sub DESTROY { $record .= "You are in MyClass_Alt::DESTROY for " . ref($_[0]) . "\n"; } package main; my $name1; my $name2; my $name3; # This demonstrates normal destruction. { my $foo = MyClass->new( 'destroy!' => sub { $record .= "You are in the objects destroy.\n"; $_[0]->super('destroy'); $record .= "Just called super-destroy.\n"; }, ); $name1 = ref($foo); } ok( $record, <new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot('p1' => $p1); } } ok( $record, <new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot('parent*' => $p1); } } ok( $record, <new( 'destroy!' => sub { $record .= "p3 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p3 after super for " . ref($_[0]) . "\n"; }, ); $name3 = ref($p3); { my $p2 = MyClass->new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot('p1' => $p1); $p3->addSlot('p1' => $p1); } } } ok( $record, <new( 'destroy!' => sub { $record .= "p3 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p3 after super for " . ref($_[0]) . "\n"; }, ); $name3 = ref($p3); { my $p2 = MyClass->new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot('parent*' => $p1); $p3->addSlot('parent*' => $p1); } } } ok( $record, <new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot([qw(parent* promote)] => $p1); } } ok( $record, <new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot('parent*' => $p1); } } ok( $record, <new( 'destroy!' => sub { $record .= "p3 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p3 after super for " . ref($_[0]) . "\n"; }, ); $name3 = ref($p3); { my $p2 = MyClass->new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot([qw(parent* promote)] => $p1); $p3->addSlot([qw(parent* promote)] => $p1); } } } ok( $record, <new( 'destroy!' => sub { $record .= "p3 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p3 after super for " . ref($_[0]) . "\n"; }, ); $name3 = ref($p3); { my $p2 = MyClass->new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); $p3->addSlot([qw(parent* promote)] => $p2); { my $p1 = MyClass->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p2->addSlot([qw(parent* promote)] => $p1); } } } ok( $record, <new( 'destroy!' => sub { $record .= "p3 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p3 after super for " . ref($_[0]) . "\n"; }, ); $name3 = ref($p3); { my $p2 = MyClass->new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); $p3->addSlot('parent2**' => $p2); { my $p1 = MyClass_Alt->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p3->addSlot('parent1**' => $p1); } } } ok( $record, <new( 'destroy!' => sub { $record .= "p3 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p3 after super for " . ref($_[0]) . "\n"; }, ); $name3 = ref($p3); { my $p2 = MyClass->new( 'destroy!' => sub { $record .= "p2 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p2 after super for " . ref($_[0]) . "\n"; }, ); $name2 = ref($p2); $p3->addSlot('parent2**' => $p2); { my $p1 = Class::Prototyped->new( 'destroy!' => sub { $record .= "p1 before super for " . ref($_[0]) . "\n"; $_[0]->super('destroy'); $record .= "p1 after super for " . ref($_[0]) . "\n"; }, ); $name1 = ref($p1); $p3->addSlot('parent1**' => $p1); } } } ok( $record, <new( name => 'p1', count => 0, ); my $ref = ref($p1); $p1->addSlots( 'new!' => sub { my $self = $_[0]->super('new', 'parent*' => @_); $self->count($self->count()+1); $record .= "Incremented count to " . $self->count . " using " . ref($self) . " from new called on " . ref($_[0]) . "\n"; return $self; }, 'destroy!' => sub { if (ref($_[0]) eq $ref) { $record .= "p1::destroy called on self with a count of " . $_[0]->count . "\n"; } else { $record .= "p1::destroy called on " . $_[0]->name() . " (" . ref($_[0]) . ")\n"; $_[0]->count($_[0]->count()-1); $record .= "Decremented count to " . $_[0]->count . "\n"; } }, ); } $name1 = ref($p1); $p2 = $p1->new(name => 'p2'); $name2 = ref($p2); $p3 = $p2->new(name => 'p3'); $name3 = ref($p3); } } } ok( $record, < 159, } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; sub Class::Prototyped::slotNames { $_[0]->reflect->slotNames } sub Class::Prototyped::allSlotNames { $_[0]->reflect->allSlotNames } sub Class::Prototyped::withAllParents { $_[0]->reflect->withAllParents } sub Class::Prototyped::allParents { $_[0]->reflect->allParents } sub Class::Prototyped::parents { $_[0]->reflect->parents } sub Class::Prototyped::slotType { (shift)->reflect->slotType(@_) } # Create empty { my $p1 = Class::Prototyped->new(); ok( defined($p1) ); ok( !$p1->can('f1') ); ok( $p1->isa('Class::Prototyped') ); ok( ref($p1) ne 'Class::Prototyped' ); ok( join ( ' ', $p1->slotNames ), '' ); ok( join ( ' ', $p1->allSlotNames ), '' ); } # Create non-empty { my $p2 = Class::Prototyped->new( f1 => 'p2.f1', f2 => 'p2.f2', s1 => sub {'p2.s1'}, s2 => sub {'p2.s2'}, s3 => sub {'p2.s3'}, ); ok( defined($p2) ); ok( join ( ' ', $p2->slotNames ), 'f1 f2 s1 s2 s3' ); ok( join ( ' ', $p2->allSlotNames ), 'f1 f2 s1 s2 s3' ); ok( $p2->isa('Class::Prototyped') ); ok( ref($p2) ne 'Class::Prototyped' ); ok( defined( $p2->can('f1') ) ); ok( $p2->f1, 'p2.f1' ); ok( join('|', $p2->reflect->findImplementation('f1')), 'self*' ); ok( scalar($p2->reflect->findImplementation('f1')), $p2 ); ok( defined( $p2->can('f2') ) ); ok( $p2->f2, 'p2.f2' ); ok( defined( $p2->can('s1') ) ); ok( $p2->s1, 'p2.s1' ); ok( join('|', $p2->reflect->findImplementation('s1')), 'self*' ); ok( scalar($p2->reflect->findImplementation('s1')), $p2 ); ok( defined( $p2->can('s2') ) ); ok( $p2->s2, 'p2.s2' ); ok( defined( $p2->can('s3') ) ); ok( $p2->s3, 'p2.s3' ); ok( !$p2->can('s4') ); ok( $p2->slotType('f1') eq 'FIELD' ); ok( defined( $p2->slotType('s1') ) ); ok( $p2->slotType('s1') eq 'METHOD' ); my @parents = $p2->parents; ok( @parents, 0 ); @parents = $p2->allParents; ok( @parents, 0 ); @parents = $p2->withAllParents; ok( @parents, 1 ); ok( $parents[0] == $p2 ); } # Inherit empty { my $p1 = Class::Prototyped->new; my $p3 = Class::Prototyped->new( 'parent*' => $p1 ); ok( defined($p3) ); ok( !defined( $p3->can('f1') ), 1, 'make sure there are no lingering f pointers' ); ok( !defined( $p3->can('s1') ), 1, 'make sure there are no lingering s pointers' ); ok( $p3->isa('Class::Prototyped') ); ok( $p3->isa( ref($p1) ) ); ok( ref($p3) ne 'Class::Prototyped' ); ok( $p3->isa( ref($p1) ) ); ok( ref($p3) ne ref($p1) ); ok( join ( ' ', $p3->slotNames ), 'parent*' ); ok( join ( ' ', $p3->allSlotNames ), 'parent*' ); my @parents = $p3->parents; ok( @parents, 1 ); ok( $parents[0] == $p1 ); @parents = $p3->allParents; ok( @parents, 1 ); ok( $parents[0] == $p1 ); @parents = $p3->withAllParents; ok( @parents, 2 ); ok( $parents[0] == $p3 ); ok( $parents[1] == $p1 ); } # Inherit empty and add slots { my $p1 = Class::Prototyped->new; my $p3 = Class::Prototyped->new( 'parent*' => $p1, f1 => 'p3.f1', f2 => 'p3.f2', s1 => sub {'p3.s1'}, ); ok( defined($p3) ); ok( $p3->isa('Class::Prototyped') ); ok( $p3->isa( ref($p1) ) ); ok( ref($p3) ne 'Class::Prototyped' ); ok( $p3->isa( ref($p1) ) ); ok( ref($p3) ne ref($p1) ); ok( defined( $p3->can('f1') ) ); ok( defined( $p3->can('f2') ) ); ok( defined( $p3->can('s1') ) ); ok( $p3->f1, 'p3.f1' ); ok( $p3->f2, 'p3.f2' ); ok( $p3->s1, 'p3.s1' ); ok( join ( ' ', $p3->slotNames ), 'parent* f1 f2 s1' ); ok( join ( ' ', $p3->allSlotNames ), 'parent* f1 f2 s1' ); } # Clone non-empty { my $p2 = Class::Prototyped->new( f1 => 'p2.f1', f2 => 'p2.f2', s1 => sub {'p2.s1'}, s2 => sub {'p2.s2'}, s3 => sub {'p2.s3'}, ); my $p3 = $p2->clone(); ok( defined($p3) ); ok( $p3->isa('Class::Prototyped') ); ok( ref($p3) ne 'Class::Prototyped' ); ok( !( $p3->isa( ref($p2) ) ) ); ok( defined( $p3->can('f1') ) ); ok( $p3->f1, 'p2.f1' ); ok( defined( $p3->can('s1') ) ); ok( $p3->s1, 'p2.s1' ); ok( !defined( $p3->can('s4') ) ); # Verify data copied not aliased ok( $p3->f1('p3.f1'), 'p3.f1' ); ok( $p3->f1, 'p3.f1' ); ok( $p2->f1, 'p2.f1' ); ok( $p3->f2, 'p2.f2' ); } # Clone non-empty and add slots at same time { my $p2 = Class::Prototyped->new( f1 => 'p2.f1', f2 => 'p2.f2', s1 => sub {'p2.s1'}, s2 => sub {'p2.s2'}, s3 => sub {'p2.s3'}, ); my $p3 = $p2->clone( f1 => 'p3.f1', s1 => sub {'p3.s1'}, ); ok( $p3->f1, 'p3.f1' ); ok( $p3->s1, 'p3.s1' ); ok( $p2->f1, 'p2.f1' ); ok( $p2->s1, 'p2.s1' ); ok( $p3->f2, 'p2.f2' ); ok( $p3->f1('p3.f1 too'), 'p3.f1 too' ); ok( $p3->f1, 'p3.f1 too' ); ok( $p2->f1, 'p2.f1' ); } # Inherit non-empty twice and add slots at same time { my $p1 = Class::Prototyped->new( f1 => 'p1.f1', f2 => 'p1.f2', f3 => 'p1.f2', s1 => sub {'p1.s1'}, s2 => sub {'p1.s2'}, s3 => sub {'p1.s3'}, ); my $p2 = $p1->new( f1 => 'p2.f1', s1 => sub {'p2.s1'}, ); my $p3 = $p2->new( f3 => 'p3.f3', s3 => sub {'p3.s3'}, ); ok( $p1->f1, 'p1.f1' ); ok( $p2->f1, 'p2.f1' ); ok( join('|', $p2->reflect->findImplementation('f1')), 'self*' ); ok( scalar($p2->reflect->findImplementation('f1')), $p2 ); ok( $p3->f1, 'p2.f1' ); ok( join('|', $p3->reflect->findImplementation('f1')), 'class*|self*' ); ok( scalar($p3->reflect->findImplementation('f1')), $p2 ); ok( $p1->s1, 'p1.s1' ); ok( $p2->s1, 'p2.s1' ); ok( join('|', $p2->reflect->findImplementation('s1')), 'self*' ); ok( scalar($p2->reflect->findImplementation('s1')), $p2 ); ok( $p3->s1, 'p2.s1' ); ok( join('|', $p3->reflect->findImplementation('s1')), 'class*|self*' ); ok( scalar($p3->reflect->findImplementation('s1')), $p2 ); ok( $p2->f1('p2.f1 too'), 'p2.f1 too' ); ok( $p2->f1, 'p2.f1 too' ); ok( $p3->f1, 'p2.f1 too' ); ok( $p3->f1('p3.f1 too'), 'p3.f1 too' ); ok( $p3->f1, 'p3.f1 too' ); ok( $p2->f1, 'p3.f1 too' ); my @parents = $p3->parents; ok( @parents, 1 ); @parents = $p3->allParents; ok( @parents, 2 ); @parents = $p3->withAllParents; ok( @parents, 3 ); ok( $parents[0] == $p3 ); ok( $parents[1] == $p2 ); ok( $parents[2] == $p1 ); ok( join('|', $p3->reflect->findImplementation('f2')), 'class*|class*|self*' ); ok( scalar($p3->reflect->findImplementation('f2')), $p1 ); } # Add a second parent { my $p1 = Class::Prototyped->new( f2 => 'p1.f2', s2 => sub {'p1.s2'}, ); my $p2 = Class::Prototyped->new( '*' => $p1, f1 => 'p2.f1', s1 => sub {'p2.s1'}, ); my $p3 = Class::Prototyped->new( f3 => 'p3.f3', s3 => sub {'p3.s3'}, ); $p2->addSlot('*' => $p3); ok( $p2->isa( ref($p1) ) ); ok( $p2->isa( ref($p3) ) ); ok( $p2->f1, 'p2.f1' ); ok( $p2->f3, 'p3.f3' ); # XXX should this be copied? ok( !defined( $p3->can('f1') ) ); ok( $p2->s1, 'p2.s1' ); ok( $p2->s3, 'p3.s3' ); ok( !defined( $p3->can('s1') ) ); ok( $p1->f2('p1.f2 too'), 'p1.f2 too' ); ok( $p1->f2, 'p1.f2 too' ); ok( $p2->f2, 'p1.f2 too' ); my @parents = $p2->parents; ok( @parents, 2 ); @parents = $p2->allParents; ok( @parents, 2 ); @parents = $p2->withAllParents; ok( @parents, 3 ); ok( $parents[0] == $p2 ); ok( $parents[1] == $p1 ); ok( $parents[2] == $p3 ); } # Clone non-empty and add slots later { my $p2 = Class::Prototyped->new( f1 => 'p2.f1', f2 => 'p2.f2', s1 => sub {'p2.s1'}, s2 => sub {'p2.s2'}, s3 => sub {'p2.s3'}, ); my $p3 = $p2->clone; $p3->addSlots( f1 => 'p3.f1', s1 => sub {'p3.s1'}, ); ok( $p3->f1, 'p3.f1' ); ok( $p3->s1, 'p3.s1' ); ok( $p2->f1, 'p2.f1' ); ok( $p2->s1, 'p2.s1' ); ok( $p3->f2, 'p2.f2' ); ok( $p3->f1('p3.f1 too'), 'p3.f1 too' ); ok( $p3->f1, 'p3.f1 too' ); } # Add slots to parent and verify inheritance { my $p1 = Class::Prototyped->new; my $p2 = Class::Prototyped->new( '*' => $p1, f1 => 'p2.f1', s1 => sub {'p2.s1'}, f2 => 'p2.f2', s2 => sub {'p2.s2'} ); $p1->addSlots( f3 => 'p1.f3', s3 => sub {'p1.s3'}, f2 => 'p1.f2', s2 => sub {'p1.s2'} ); ok( $p2->f1, 'p2.f1' ); ok( $p2->f2, 'p2.f2' ); ok( $p2->f3, 'p1.f3' ); ok( $p2->s1, 'p2.s1' ); ok( $p2->s2, 'p2.s2' ); ok( $p2->s3, 'p1.s3' ); # defined in parent; get it through inheritance } # Delete slots from child and verify inheritance { my $p1 = Class::Prototyped->new( f3 => 'p1.f3', s3 => sub {'p1.s3'}, f2 => 'p1.f2', s2 => sub {'p1.s2'} ); my $p2 = Class::Prototyped->new( '*' => $p1, f1 => 'p2.f1', s1 => sub {'p2.s1'}, f2 => 'p2.f2', s2 => sub {'p2.s2'} ); $p2->deleteSlots(qw(f2 s2)); ok( $p2->f1, 'p2.f1' ); ok( $p2->f2, 'p1.f2' ); ok( $p2->s1, 'p2.s1' ); ok( $p2->s2, 'p1.s2' ); } # Delete slots in parent without disturbing child { my $p1 = Class::Prototyped->new( f3 => 'p1.f3', s3 => sub {'p1.s3'}, f2 => 'p1.f2', s2 => sub {'p1.s2'} ); my $p2 = Class::Prototyped->new( f1 => 'p2.f1', s1 => sub {'p2.s1'}, f2 => 'p2.f2', s2 => sub {'p2.s2'} ); $p1->deleteSlots(qw(f2 s2)); ok( $p2->f1, 'p2.f1' ); ok( $p2->f2, 'p2.f2' ); ok( $p2->s1, 'p2.s1' ); ok( $p2->s2, 'p2.s2' ); } # Delete slots in child and make sub undef # Delete slots in child and make field undef { my $p1 = Class::Prototyped->new( f3 => 'p1.f3', s3 => sub {'p1.s3'}, f2 => 'p1.f2', s2 => sub {'p1.s2'} ); my $p2 = $p1->clone( f1 => 'p2.f1', s1 => sub {'p2.s1'}, f2 => 'p2.f2', s2 => sub {'p2.s2'} ); $p2->deleteSlots(qw(f1 s1)); ok( !defined( $p2->can('f1') ) ); ok( !defined( $p2->can('s1') ) ); } # Delete slots in parent and make sub undef # Delete slots in parent and make field undef { my $p1 = Class::Prototyped->new( f3 => 'p1.f3', s3 => sub {'p1.s3'}, f2 => 'p1.f2', s2 => sub {'p1.s2'} ); my $p2 = Class::Prototyped->new( '*' => $p1, f1 => 'p2.f1', s1 => sub {'p2.s1'}, f2 => 'p2.f2', s2 => sub {'p2.s2'} ); $p1->deleteSlots(qw(f3 s3)); ok( !defined( $p2->can('f3') ) ); ok( !defined( $p2->can('s3') ) ); } # Verify slot inheritance works after parent add slots { my $p1 = Class::Prototyped->new; my $p2 = Class::Prototyped->new( '*' => $p1 ); $p1->addSlots( f1 => 'p1.f1', s1 => sub {'p1.s1'}, ); ok( $p2->f1, 'p1.f1' ); # XXX should this copy? ok( $p2->s1, 'p1.s1' ); } # Add slots to child & verify child gets new behavior { my $p1 = Class::Prototyped->new; my $p2 = Class::Prototyped->new; $p2->addSlots( '*' => $p1, f1 => 'p2.f1', s1 => sub {'p2.s1'}, ); ok( $p2->f1, 'p2.f1' ); ok( $p2->s1, 'p2.s1' ); } # Override a data slot with a sub slot # Override a sub slot with a data slot # Replace a data slot with a sub slot # Replace a sub slot with a data slot # Test data dumper behavior # vim: ft=perl Class-Prototyped-1.16/t/autoload.t0000444000175000017500000001127214674671765015661 0ustar tobytobyuse strict; $^W++; use Class::Prototyped qw(:NEW_MAIN); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 35; } $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1; my $p1 = new( a => 2, [qw(b FIELD autoload)] => sub { time }); ok( Data::Dumper->Dump([[ $p1->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {autoload => 1}, type => 'FIELD', value => sub {} } ]]) ); my $p2 = $p1->clone(); ok( Data::Dumper->Dump([[ $p2->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {autoload => 1}, type => 'FIELD', value => sub {} } ]]) ); my $timea = time; my $time1 = $p1->b; my $timez = time; ok( $time1 >= $timea); ok( $time1 <= $timez); ok( Data::Dumper->Dump([[ $p1->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {}, type => 'FIELD', value => $time1 } ]]) ); while ($time1 == time) { sleep(1); } ok( time != $p1->b ); ok( Data::Dumper->Dump([[ $p2->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {autoload => 1}, type => 'FIELD', value => sub {} } ]]) ); $timea = time; my $time2 = $p2->b; $timez = time; ok( $time2 >= $timea); ok( $time2 <= $timez); ok( Data::Dumper->Dump([[ $p2->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {}, type => 'FIELD', value => $time2 } ]]) ); while ($time2 == time) { sleep(1); } ok( time != $p2->b ); my $p3 = $p1->clone(); ok( Data::Dumper->Dump([[ $p3->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {}, type => 'FIELD', value => $time1 } ]]) ); $p3->b(7); ok( $p3->b, 7 ); my $p4 = new( a => 2, [qw(b FIELD autoload)] => sub { $_[0]->a }); $p4->a(5); ok( $p4->a, 5 ); ok( $p4->b, 5 ); $p4->a(2); ok( $p4->a, 2 ); ok( $p4->b, 5 ); my $p5 = new( a => 4, [qw(b FIELD autoload)] => sub { [ map {rand()} 1..$_[0]->a ] }); my $p6 = $p5->clone; $p6->a(6); ok( scalar(@{$p5->b}), 4); ok( scalar(@{$p6->b}), 6); ok( scalar($p5->b), "".$p5->b); my $p7 = new( a => 2, [qw(b FIELD autoload)] => sub { defined $_[1] ? $_[1] : time }); ok( Data::Dumper->Dump([[ $p7->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {autoload => 1}, type => 'FIELD', value => sub {} } ]]) ); my $time7 = $p7->b(5); ok( $time7, 5); ok( Data::Dumper->Dump([[ $p7->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {}, type => 'FIELD', value => $time7 } ]]) ); my $p8 = new( a => 2, [qw(b FIELD autoload)] => sub { defined $_[1] ? $_[1] : time }); ok( Data::Dumper->Dump([[ $p8->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {autoload => 1}, type => 'FIELD', value => sub {} } ]]) ); $timea = time; my $time8 = $p8->b; $timez = time; ok( $time8 >= $timea); ok( $time8 <= $timez); ok( Data::Dumper->Dump([[ $p8->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {}, type => 'FIELD', value => $time8 } ]]) ); my $p9 = new( a => 2, [qw(b FIELD autoload 1 constant 1)] => sub { time }); $timea = time; my $time9 = $p9->b; $timez = time; ok( $time9 >= $timea); ok( $time9 <= $timez); ok( Data::Dumper->Dump([[ $p9->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 2 }, b => { attribs => {constant => 1}, type => 'FIELD', value => $time9 } ]]) ); $p9->b(5); ok( $p9->b, $time9 ); my $p10 = new( a => 4, [qw(b FIELD autoload 1 wantarray 1)] => sub { [ map {rand()} 1..$_[0]->a ] }); ok( Data::Dumper->Dump([[ $p10->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 4 }, b => { attribs => {autoload => 1, wantarray => 1}, type => 'FIELD', value => sub {} } ]]) ); ok( scalar(@{$p10->b}), 4); ok( scalar($p10->b), "".$p10->b); ok( Data::Dumper->Dump([[ $p10->reflect->getSlots(undef, 'rotated') ]]), Data::Dumper->Dump([[ a => { attribs => {}, type => 'FIELD', value => 4 }, b => { attribs => {wantarray => 1}, type => 'FIELD', value => scalar($p10->b) } ]]) ); Class-Prototyped-1.16/META.yml0000444000175000017500000000244514674671765014674 0ustar tobytoby--- abstract: 'Fast prototype-based OO programming in Perl' author: - 'Written by Ned Konz, perl@bike-nomad.com and Toby Ovod-Everett, toby@ovod-everett.org. 5.005_03 porting by chromatic.' build_requires: {} configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Class-Prototyped provides: Class::Prototyped: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Mirror: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Mirror::Normal: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Mirror::PROFILE: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Mirror::SUPER: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Tied: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Tied::AutoVivify: file: lib/Class/Prototyped.pm version: '1.16' Class::Prototyped::Tied::Default: file: lib/Class/Prototyped.pm version: '1.16' resources: license: http://dev.perl.org/licenses/ version: '1.16' x_serialization_backend: 'CPAN::Meta::YAML version 0.018'