diff options
Diffstat (limited to 'lib/Class/MakeMethods/Emulator')
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/AccessorFast.pm | 102 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/Inheritable.pm | 162 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/MethodMaker.pm | 676 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/Singleton.pm | 85 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/Struct.pm | 154 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/accessors.pm | 122 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Emulator/mcoder.pm | 116 |
7 files changed, 1417 insertions, 0 deletions
diff --git a/lib/Class/MakeMethods/Emulator/AccessorFast.pm b/lib/Class/MakeMethods/Emulator/AccessorFast.pm new file mode 100644 index 0000000..0f47e04 --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/AccessorFast.pm @@ -0,0 +1,102 @@ +package Class::MakeMethods::Emulator::AccessorFast; + +use strict; +use Class::MakeMethods::Composite::Hash; +use Class::MakeMethods::Emulator '-isasubclass'; + +sub _emulator_target { 'Class::Accessor::Fast' } + +sub import { + my $class = shift; + $class->_handle_namespace( $class->_emulator_target, $_[0] ) and shift; +} + +######################################################################## + +sub mk_accessors { + Class::MakeMethods::Composite::Hash->make( + -TargetClass => (shift), + 'new' => { name => 'new', modifier => 'with_values' }, + 'scalar' => [ map { + $_, + "_${_}_accessor", { 'hash_key' => $_ } + } @_ ], + ); +} + +sub mk_ro_accessors { + Class::MakeMethods::Composite::Hash->make( + -TargetClass => (shift), + 'new' => { name => 'new', modifier => 'with_values' }, + 'scalar' => [ map { + $_, { permit => 'ro' }, + "_${_}_accessor", { 'hash_key' => $_, permit => 'ro' } + } @_ ], + ); +} + +sub mk_wo_accessors { + Class::MakeMethods::Composite::Hash->make( + -TargetClass => (shift), + 'new' => { name => 'new', modifier => 'with_values' }, + 'scalar' => [ map { + $_, { permit => 'wo' }, + "_${_}_accessor", { 'hash_key' => $_, permit => 'wo' } + } @_ ], + ); +} + +######################################################################## + +1; + +__END__ + + +=head1 NAME + +Class::MakeMethods::Emulator::AccessorFast - Emulate Class::Accessor::Fast + + +=head1 SYNOPSIS + + package Foo; + + use base qw(Class::MakeMethods::Emulator::AccessorFast); + Foo->mk_accessors(qw(this that whatever)); + + # Meanwhile, in a nearby piece of code! + # Emulator::AccessorFast provides new(). + my $foo = Foo->new; + + my $whatever = $foo->whatever; # gets $foo->{whatever} + $foo->this('likmi'); # sets $foo->{this} = 'likmi' + + +=head1 DESCRIPTION + +This module emulates the functionality of Class::Accessor::Fast, using Class::MakeMethods to generate similar methods. + +You may use it directly, as shown in the SYNOPSIS above, + +Furthermore, you may call C<use Class::MakeMethods::Emulator::AccessorFast +'-take_namespace';> to alias the Class::Accessor::Fast namespace +to this package, and subsequent calls to the original package will +be transparently handled by this emulator. To remove the emulation +aliasing, call C<use Class::MakeMethods::Emulator::AccessorFast +'-release_namespace'>. + +B<Caution:> This affects B<all> subsequent uses of Class::Accessor::Fast +in your program, including those in other modules, and might cause +unexpected effects. + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L<Class::Accessor::Fast> for documentation of the original module. + +=cut diff --git a/lib/Class/MakeMethods/Emulator/Inheritable.pm b/lib/Class/MakeMethods/Emulator/Inheritable.pm new file mode 100644 index 0000000..90b0a91 --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/Inheritable.pm @@ -0,0 +1,162 @@ +package Class::MakeMethods::Emulator::Inheritable; + +use strict; + +use Class::MakeMethods::Template::ClassInherit; +use Class::MakeMethods::Emulator qw( namespace_capture namespace_release ); + +my $emulation_target = 'Class::Data::Inheritable'; + +sub import { + my $mm_class = shift; + if ( scalar @_ and $_[0] =~ /^-take_namespace/ and shift) { + namespace_capture(__PACKAGE__, $emulation_target); + } elsif ( scalar @_ and $_[0] =~ /^-release_namespace/ and shift) { + namespace_release(__PACKAGE__, $emulation_target); + } + # The fallback should really be to NEXT::import. + $mm_class->SUPER::import( @_ ); +} + +######################################################################## + +sub mk_classdata { + my $declaredclass = shift; + my $attribute = shift; + Class::MakeMethods::Template::ClassInherit->make( + -TargetClass => $declaredclass, + 'scalar' => [ -interface => { '*'=>'get_set', '_*_accessor'=>'get_set' }, + $attribute ], + ); + if ( scalar @_ ) { + $declaredclass->$attribute( @_ ); + } +} + +######################################################################## + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Emulator::Inheritable - Emulate Class::Inheritable + + +=head1 SYNOPSIS + + package Stuff; + use base qw(Class::MakeMethods::Emulator::Inheritable); + + # Set up DataFile as inheritable class data. + Stuff->mk_classdata('DataFile'); + + # Declare the location of the data file for this class. + Stuff->DataFile('/etc/stuff/data'); + + +=head1 DESCRIPTION + +This module is an adaptor that provides emulatation of Class::Data::Inheritable by invoking similiar functionality provided by Class::MakeMethods::ClassInherit. + +The public interface provided by Class::MakeMethods::Emulator::Inheritable is identical to that of Class::Data::Inheritable. + +Class::Data::Inheritable is for creating accessor/mutators to class +data. That is, if you want to store something about your class as a +whole (instead of about a single object). This data is then inherited +by your subclasses and can be overriden. + +=head1 USAGE + +As specified by L<Class::Data::Inheritable>, clients should inherit from this module and then invoke the mk_classdata() method for each class method desired: + + Class->mk_classdata($data_accessor_name); + +This is a class method used to declare new class data accessors. A +new accessor will be created in the Class using the name from +$data_accessor_name. + + Class->mk_classdata($data_accessor_name, $initial_value); + +You may also pass a second argument to initialize the value. + +To facilitate overriding, mk_classdata creates an alias to the +accessor, _field_accessor(). So Suitcase() would have an alias +_Suitcase_accessor() that does the exact same thing as Suitcase(). +This is useful if you want to alter the behavior of a single accessor +yet still get the benefits of inheritable class data. For example. + + sub Suitcase { + my($self) = shift; + warn "Fashion tragedy" if @_ and $_[0] eq 'Plaid'; + + $self->_Suitcase_accessor(@_); + } + + +=head1 COMPATIBILITY + +Note that the internal implementation of Class::MakeMethods::ClassInherit does not match that of Class::Data::Inheritable. In particular, Class::Data::Inheritable installs new methods in subclasses when they first initialize their value, while + +=head1 EXAMPLE + +The example provided by L<Class::Data::Inheritable> is equally applicable to this emulator. + + package Pere::Ubu; + use base qw(Class::MakeMethods::Emulator::Inheritable); + Pere::Ubu->mk_classdata('Suitcase'); + +will generate the method Suitcase() in the class Pere::Ubu. + +This new method can be used to get and set a piece of class data. + + Pere::Ubu->Suitcase('Red'); + $suitcase = Pere::Ubu->Suitcase; + +The interesting part happens when a class inherits from Pere::Ubu: + + package Raygun; + use base qw(Pere::Ubu); + + # Raygun's suitcase is Red. + $suitcase = Raygun->Suitcase; + +Raygun inherits its Suitcase class data from Pere::Ubu. + +Inheritance of class data works analgous to method inheritance. As +long as Raygun does not "override" its inherited class data (by using +Suitcase() to set a new value) it will continue to use whatever is set +in Pere::Ubu and inherit further changes: + + # Both Raygun's and Pere::Ubu's suitcases are now Blue + Pere::Ubu->Suitcase('Blue'); + +However, should Raygun decide to set its own Suitcase() it has now +"overridden" Pere::Ubu and is on its own, just like if it had +overriden a method: + + # Raygun has an orange suitcase, Pere::Ubu's is still Blue. + Raygun->Suitcase('Orange'); + +Now that Raygun has overridden Pere::Ubu futher changes by Pere::Ubu +no longer effect Raygun. + + # Raygun still has an orange suitcase, but Pere::Ubu is using Samsonite. + Pere::Ubu->Suitcase('Samsonite'); + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L<Class::Data::Inheritable> for documentation of the original module. + +See L<perltootc> for a discussion of class data in Perl. + +See L<Class::MakeMethods::Standard::Inheritable> and L<Class::MakeMethods::Template::ClassInherit> for inheritable data methods. + +=cut + diff --git a/lib/Class/MakeMethods/Emulator/MethodMaker.pm b/lib/Class/MakeMethods/Emulator/MethodMaker.pm new file mode 100644 index 0000000..4956ba3 --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/MethodMaker.pm @@ -0,0 +1,676 @@ +package Class::MakeMethods::Emulator::MethodMaker; + +use Class::MakeMethods '-isasubclass'; +require Class::MakeMethods::Emulator; + +$VERSION = 1.03; + +use strict; + +=head1 NAME + +Class::MakeMethods::Emulator::MethodMaker - Emulate Class::MethodMaker + + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Emulator::MethodMaker( + new_with_init => 'new', + get_set => [ qw / foo bar baz / ]; + ); + + ... OR ... + + package MyObject; + use Class::MakeMethods::Emulator::MethodMaker '-take_namespace'; + use Class::MethodMaker ( + new_with_init => 'new', + get_set => [ qw / foo bar baz / ]; + ); + + +=head1 DESCRIPTION + +This module provides emulation of Class::MethodMaker, using the Class::MakeMethods framework. + +Although originally based on Class::MethodMaker, the calling convention +for Class::MakeMethods differs in a variety of ways; most notably, the names +given to various types of methods have been changed, and the format for +specifying method attributes has been standardized. This package uses +the aliasing capability provided by Class::MakeMethods, defining methods +that modify the declaration arguments as necessary and pass them off to +various subclasses of Class::MakeMethods. + + +=head1 COMPATIBILITY + +Full compatibility is maintained with version 1.03; some of the +changes in versions 1.04 through 1.10 are not yet included. + +The test suite from Class::MethodMaker version 1.10 is included +with this package, in the t/emulator_class_methodmaker/ directory. +The unsupported tests have names ending in ".todo". + +The tests are unchanged from those in the Class::MethodMaker +distribution, except for the substitution of +C<Class::MakeMethods::Emulator::MethodMaker> in the place of +C<Class::MethodMaker>. + +In cases where earlier distributions of Class::MethodMaker contained +a different version of a test, it is also included. (Note that +version 0.92's get_concat returned '' for empty values, but in +version 0.96 this was changed to undef; this emulator follows the +later behavior. To avoid "use of undefined value" warnings from +the 0.92 version of get_concat.t, that test has been modified by +appending a new flag after the name, C<'get_concat --noundef'>, +which restores the earlier behavior.) + + +=head1 USAGE + +There are several ways to call this emulation module: + +=over 4 + +=item * + +Direct Access + +Replace occurances in your code of C<Class::MethodMaker> with C<Class::MakeMethods::Emulator::MethodMaker>. + +=item * + +Install Emulation + +If you C<use Class::MakeMethods::Emulator::MethodMaker '-take_namespace'>, the Class::MethodMaker namespace will be aliased to this package, and calls to the original package will be transparently handled by this emulator. + +To remove the emulation aliasing, call C<use Class::MakeMethods::Emulator::MethodMaker '-release_namespace'>. + +B<Note:> This affects B<all> subsequent uses of Class::MethodMaker in your program, including those in other modules, and might cause unexpected effects. + +=item * + +The -sugar Option + +Passing '-sugar' as the first argument in a use or import call will cause the 'methods' package to be declared as an alias to this one. + +This allows you to write declarations in the following manner. + + use Class::MakeMethods::Emulator::MethodMaker '-sugar'; + + make methods + get_set => [ qw / foo bar baz / ], + list => [ qw / a b c / ]; + +B<Note:> This feature is deprecated in Class::MethodMaker version 0.96 and later. + +=back + +=cut + +my $emulation_target = 'Class::MethodMaker'; + +sub import { + my $mm_class = shift; + + if ( scalar @_ and $_[0] =~ /^-take_namespace/ and shift ) { + Class::MakeMethods::Emulator::namespace_capture(__PACKAGE__, $emulation_target); + } elsif ( scalar @_ and $_[0] =~ /^-release_namespace/ and shift ) { + Class::MakeMethods::Emulator::namespace_release(__PACKAGE__, $emulation_target); + } + + if ( scalar @_ and $_[0] eq '-sugar' and shift ) { + Class::MakeMethods::Emulator::namespace_capture(__PACKAGE__, "methods"); + } + + $mm_class->make( @_ ) if ( scalar @_ ); +} + + +=head1 METHOD CATALOG + +B<NOTE:> The documentation below is derived from version 1.02 of +Class::MethodMaker. Class::MakeMethods::Emulator::MethodMaker +provides support for all of the features and examples shown below, +with no changes required. + + +=head1 CONSTRUCTOR METHODS + +=head2 new + +Equivalent to Class::MakeMethods 'Template::Hash:new --with_values'. + +=cut + +sub new { return 'Template::Hash:new --with_values' } + + +=head2 new_with_init + +Equivalent to Class::MakeMethods 'Template::Hash:new --with_init'. + +=cut + +sub new_with_init { return 'Template::Hash:new --with_init' } + + +=head2 new_hash_init + +Equivalent to Class::MakeMethods 'Template::Hash:new --instance_with_methods'. + +=cut + +sub new_hash_init { return 'Template::Hash:new --instance_with_methods' } + + +=head2 new_with_args + +Equivalent to Class::MakeMethods 'Template::Hash:new --with_values'. + +=cut + +sub new_with_args { return 'Template::Hash:new --with_values' } + + +=head2 copy + +Equivalent to Class::MakeMethods 'Template::Hash:new --copy_with_values'. + +=cut + +sub copy { return 'Template::Hash:new --copy_with_values' } + + +=head1 SCALAR ACCESSORS + +=head2 get_set + +Basically equivalent to Class::MakeMethods 'Template::Hash:scalar', except that various arguments are intercepted and converted into the parallel Class::MakeMethods::Template interface declarations. + +=cut + +my $scalar_interface = { '*'=>'get_set', 'clear_*'=>'clear' }; + +sub get_set { + shift and return [ + ( ( $_[0] and $_[0] eq '-static' and shift ) ? 'Template::Static:scalar' + : 'Template::Hash:scalar' ), + '-interface' => $scalar_interface, + map { + ( ref($_) eq 'ARRAY' ) + ? ( '-interface'=>{ + ( $_->[0] ? ( $_->[0] => 'get_set' ) : () ), + ( $_->[1] ? ( $_->[1] => 'clear' ) : () ), + ( $_->[2] ? ( $_->[2] => 'get' ) : () ), + ( $_->[3] ? ( $_->[3] => 'set_return' ) : () ), + } ) + : ($_ eq '-compatibility') + ? ( '-interface', $scalar_interface ) + : ($_ eq '-noclear') + ? ( '-interface', 'default' ) + : ( /^-/ ? "-$_" : $_ ) + } @_ + ] +} + + +=head2 get_concat + +Equivalent to Class::MakeMethods 'Template::Hash:string' with a special interface declaration that provides the get_concat and clear behaviors. + +=cut + +my $get_concat_interface = { + '*'=>'get_concat', 'clear_*'=>'clear', + '-params'=>{ 'join' => '', 'return_value_undefined' => undef() } +}; + +my $old_get_concat_interface = { + '*'=>'get_concat', 'clear_*'=>'clear', + '-params'=>{ 'join' => '', 'return_value_undefined' => '' } +}; + +sub get_concat { + shift and return [ 'Template::Hash:string', '-interface', + ( $_[0] eq '--noundef' ? ( shift and $old_get_concat_interface ) + : $get_concat_interface ), @_ ] +} + +=head2 counter + +Equivalent to Class::MakeMethods 'Template::Hash:number --counter'. + +=cut + +sub counter { return 'Template::Hash:number --counter' } + + +=head1 OBJECT ACCESSORS + +Basically equivalent to Class::MakeMethods 'Template::Hash:object' with an declaration that provides the "delete_x" interface. Due to a difference in expected argument syntax, the incoming arguments are revised before being delegated to Template::Hash:object. + +=cut + +my $object_interface = { '*'=>'get_set_init', 'delete_*'=>'clear' }; + +sub object { + shift and return [ + 'Template::Hash:object', + '-interface' => $object_interface, + _object_args(@_) + ] +} + +sub _object_args { + my @meta_methods; + ! (@_ % 2) or Carp::croak("Odd number of arguments for object declaration"); + while ( scalar @_ ) { + my ($class, $list) = (shift(), shift()); + push @meta_methods, map { + (! ref $_) ? { name=> $_, class=>$class } + : { name=> $_->{'slot'}, class=>$class, + delegate=>( $_->{'forward'} || $_->{'comp_mthds'} ) } + } ( ( ref($list) eq 'ARRAY' ) ? @$list : ($list) ); + } + return @meta_methods; +} + + +=head2 object_list + +Basically equivalent to Class::MakeMethods 'Template::Hash:object_list' with an declaration that provides the relevant helper methods. Due to a difference in expected argument syntax, the incoming arguments are revised before being delegated to Template::Hash:object_list. + +=cut + +my $array_interface = { + '*'=>'get_push', + '*_set'=>'set_items', 'set_*'=>'set_items', + map( ('*_'.$_ => $_, $_.'_*' => $_ ), + qw( pop push unshift shift splice clear count ref index )), +}; + +sub object_list { + shift and return [ + 'Template::Hash:array_of_objects', + '-interface' => $array_interface, + _object_args(@_) + ]; +} + +=head2 forward + +Basically equivalent to Class::MakeMethods 'Template::Universal:forward_methods'. Due to a difference in expected argument syntax, the incoming arguments are revised before being delegated to Template::Universal:forward_methods. + + forward => [ comp => 'method1', comp2 => 'method2' ] + +Define pass-through methods for certain fields. The above defines that +method C<method1> will be handled by component C<comp>, whilst method +C<method2> will be handled by component C<comp2>. + +=cut + +sub forward { + my $class = shift; + my @results; + while ( scalar @_ ) { + my ($comp, $method) = ( shift, shift ); + push @results, { name=> $method, target=> $comp }; + } + [ 'forward_methods', @results ] +} + + + +=head1 REFERENCE ACCESSORS + +=head2 list + +Equivalent to Class::MakeMethods 'Template::Hash:array' with a custom method naming interface. + +=cut + +sub list { + shift and return [ 'Template::Hash:array', '-interface' => $array_interface, @_ ]; +} + + +=head2 hash + +Equivalent to Class::MakeMethods 'Template::Hash:hash' with a custom method naming interface. + +=cut + +my $hash_interface = { + '*'=>'get_push', + '*s'=>'get_push', + 'add_*'=>'get_set_items', + 'add_*s'=>'get_set_items', + 'clear_*'=>'delete', + 'clear_*s'=>'delete', + map {'*_'.$_ => $_} qw(push set keys values exists delete tally clear), +}; + +sub hash { + shift and return [ 'Template::Hash:hash', '-interface' => $hash_interface, @_ ]; +} + + +=head2 tie_hash + +Equivalent to Class::MakeMethods 'Template::Hash:tiedhash' with a custom method naming interface. + +=cut + +sub tie_hash { + shift and return [ 'Template::Hash:tiedhash', '-interface' => $hash_interface, @_ ]; +} + +=head2 hash_of_lists + +Equivalent to Class::MakeMethods 'Template::Hash:hash_of_arrays', or if the -static flag is present, to 'Template::Static:hash_of_arrays'. + +=cut + +sub hash_of_lists { + shift and return ( $_[0] and $_[0] eq '-static' and shift ) + ? [ 'Template::Static:hash_of_arrays', @_ ] + : [ 'Template::Hash:hash_of_arrays', @_ ] +} + + +=head1 STATIC ACCESSORS + +=head2 static_get_set + +Equivalent to Class::MakeMethods 'Template::Static:scalar' with a custom method naming interface. + +=cut + +sub static_get_set { + shift and return [ 'Template::Static:scalar', '-interface', $scalar_interface, @_ ] +} + +=head2 static_list + +Equivalent to Class::MakeMethods 'Template::Static:array' with a custom method naming interface. + +=cut + +sub static_list { + shift and return [ 'Template::Static:array', '-interface' => $array_interface, @_ ]; +} + +=head2 static_hash + +Equivalent to Class::MakeMethods 'Template::Static:hash' with a custom method naming interface. + +=cut + +sub static_hash { + shift and return [ 'Template::Static:hash', '-interface' => $hash_interface, @_ ]; +} + + +=head1 GROUPED ACCESSORS + +=head2 boolean + +Equivalent to Class::MakeMethods 'Template::Static:bits' with a custom method naming interface. + +=cut + +my $bits_interface = { + '*'=>'get_set', 'set_*'=>'set_true', 'clear_*'=>'set_false', + 'bit_fields'=>'bit_names', 'bits'=>'bit_string', 'bit_dump'=>'bit_hash' +}; + +sub boolean { + shift and return [ 'Template::Hash:bits', '-interface' => $bits_interface, @_ ]; +} + + +=head2 grouped_fields + +Creates get/set methods like get_set but also defines a method which +returns a list of the slots in the group. + + use Class::MakeMethods::Emulator::MethodMaker + grouped_fields => [ + some_group => [ qw / field1 field2 field3 / ], + ]; + +Its argument list is parsed as a hash of group-name => field-list +pairs. Get-set methods are defined for all the fields and a method with +the name of the group is defined which returns the list of fields in the +group. + +=cut + +sub grouped_fields { + my ($class, %args) = @_; + my @methods; + foreach (keys %args) { + my @slots = @{ $args{$_} }; + push @methods, + $_, sub { @slots }, + $class->make( 'get_set', \@slots ); + } + return @methods; +} + +=head2 struct + +Equivalent to Class::MakeMethods 'Template::Hash::struct'. + +B<Note:> This feature is included but not documented in Class::MethodMaker version 1. + + +=cut + +sub struct { return 'Template::Hash:struct' } + + +=head1 INDEXED ACCESSORS + +=head2 listed_attrib + +Equivalent to Class::MakeMethods 'Template::Flyweight:boolean_index' with a custom method naming interface. + +=cut + +sub listed_attrib { + shift and return [ 'Template::Flyweight:boolean_index', '-interface' => { + '*'=>'get_set', 'set_*'=>'set_true', 'clear_*'=>'set_false', + '*_objects'=>'find_true', }, @_ ] +} + + +=head2 key_attrib + +Equivalent to Class::MakeMethods 'Template::Hash:string_index'. + +=cut + +sub key_attrib { return 'Template::Hash:string_index' } + +=head2 key_with_create + +Equivalent to Class::MakeMethods 'Template::Hash:string_index --find_or_new'. + +=cut + +sub key_with_create { return 'Template::Hash:string_index --find_or_new'} + + +=head1 CODE ACCESSORS + +=head2 code + +Equivalent to Class::MakeMethods 'Template::Hash:code'. + +=cut + +sub code { return 'Template::Hash:code' } + + +=head2 method + +Equivalent to Class::MakeMethods 'Template::Hash:code --method'. + +=cut + +sub method { return 'Template::Hash:code --method' } + + +=head2 abstract + +Equivalent to Class::MakeMethods 'Template::Universal:croak --abstract'. + +=cut + +sub abstract { return 'Template::Universal:croak --abstract' } + + +=head1 ARRAY CONSTRUCTOR AND ACCESSORS + +=head2 builtin_class (EXPERIMENTAL) + +Equivalent to Class::MakeMethods 'Template::StructBuiltin:builtin_isa' with a modified argument order. + +=cut + +sub builtin_class { + shift and return [ 'Template::StructBuiltin:builtin_isa', + '-new_function'=>(shift), @{(shift)} ] +} + +=head1 CONVERSION + +If you wish to convert your code from use of the Class::MethodMaker emulator to direct use of Class::MakeMethods, you will need to adjust the arguments specified in your C<use> or C<make> calls. + +Often this is simply a matter of replacing the names of aliased method-types listed below with the new equivalents. + +For example, suppose that you code contained the following declaration: + + use Class::MethodMaker ( + counter => [ 'foo' ] + ); + +Consulting the listings below you can find that C<counter> is an alias for C<Hash:number --counter> and you could thus revise your declaration to read: + + use Class::MakeMethods ( + 'Hash:number --counter' => [ 'foo' ] + ); + +However, note that those methods marked "(with custom interface)" below have a different default naming convention for helper methods in Class::MakeMethods, and you will need to either supply a similar interface or alter your module's calling interface. + +Also note that the C<forward>, C<object>, and C<object_list> method types, marked "(with modified arguments)" below, require their arguments to be specified differently. + +See L<Class::MakeMethods::Template::Generic> for more information about the default interfaces of these method types. + + +=head2 Hash methods + +The following equivalencies are declared for old meta-method names that are now handled by the Hash implementation: + + new 'Template::Hash:new --with_values' + new_with_init 'Template::Hash:new --with_init' + new_hash_init 'Template::Hash:new --instance_with_methods' + copy 'Template::Hash:copy' + get_set 'Template::Hash:scalar' (with custom interfaces) + counter 'Template::Hash:number --counter' + get_concat 'Template::Hash:string --get_concat' (with custom interface) + boolean 'Template::Hash:bits' (with custom interface) + list 'Template::Hash:array' (with custom interface) + struct 'Template::Hash:struct' + hash 'Template::Hash:hash' (with custom interface) + tie_hash 'Template::Hash:tiedhash' (with custom interface) + hash_of_lists 'Template::Hash:hash_of_arrays' + code 'Template::Hash:code' + method 'Template::Hash:code --method' + object 'Template::Hash:object' (with custom interface and modified arguments) + object_list 'Template::Hash:array_of_objects' (with custom interface and modified arguments) + key_attrib 'Template::Hash:string_index' + key_with_create 'Template::Hash:string_index --find_or_new' + +=head2 Static methods + +The following equivalencies are declared for old meta-method names +that are now handled by the Static implementation: + + static_get_set 'Template::Static:scalar' (with custom interface) + static_hash 'Template::Static:hash' (with custom interface) + +=head2 Flyweight method + +The following equivalency is declared for the one old meta-method name +that us now handled by the Flyweight implementation: + + listed_attrib 'Template::Flyweight:boolean_index' + +=head2 Struct methods + +The following equivalencies are declared for old meta-method names +that are now handled by the Struct implementation: + + builtin_class 'Template::Struct:builtin_isa' + +=head2 Universal methods + +The following equivalencies are declared for old meta-method names +that are now handled by the Universal implementation: + + abstract 'Template::Universal:croak --abstract' + forward 'Template::Universal:forward_methods' (with modified arguments) + + +=head1 EXTENDING + +In order to enable third-party subclasses of MethodMaker to run under this emulator, several aliases or stub replacements are provided for internal Class::MethodMaker methods which have been eliminated or renamed. + +=over 4 + +=item * + +install_methods - now simply return the desired methods + +=item * + +find_target_class - now passed in as the target_class attribute + +=item * + +ima_method_maker - no longer supported; use target_class instead + +=back + +=cut + +sub find_target_class { (shift)->_context('TargetClass') } +sub get_target_class { (shift)->_context('TargetClass') } +sub install_methods { (shift)->_install_methods(@_) } +sub ima_method_maker { 1 } + + +=head1 BUGS + +This module aims to provide a 100% compatible drop-in replacement for Class::MethodMaker; if you detect a difference when using this emulation, please inform the author. + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L<Class::MethodMaker> for more information about the original module. + +A good introduction to Class::MethodMaker is provided by pages 222-234 of I<Object Oriented Perl>, by Damian Conway (Manning, 1999). + + http://www.browsebooks.com/Conway/ + +=cut + +1; diff --git a/lib/Class/MakeMethods/Emulator/Singleton.pm b/lib/Class/MakeMethods/Emulator/Singleton.pm new file mode 100644 index 0000000..c47ad9e --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/Singleton.pm @@ -0,0 +1,85 @@ +package Class::MakeMethods::Emulator::Singleton; + +use strict; +require Class::MakeMethods::Emulator; + +my $emulation_target = 'Class::Singleton'; + +sub import { + my $mm_class = shift; + if ( scalar @_ and $_[0] =~ /^-take_namespace/ and shift) { + Class::MakeMethods::Emulator::namespace_capture(__PACKAGE__, $emulation_target); + } elsif ( scalar @_ and $_[0] =~ /^-release_namespace/ and shift) { + Class::MakeMethods::Emulator::namespace_release(__PACKAGE__, $emulation_target); + } + # The fallback should really be to NEXT::import. + $mm_class->SUPER::import( @_ ); +} + +######################################################################## + +use Class::MakeMethods ( + 'Template::Hash:new --with_values' => '_new_instance', + 'Template::ClassVar:instance --get_init' => [ 'instance', + {new_method=>'_new_instance', variable=>'_instance'} ] +); + +######################################################################## + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Emulator::Singleton - Emulate Class::Singleton + + +=head1 SYNOPSIS + + use Class::MakeMethods::Emulator::Singleton; + + # returns a new instance + my $one = Class::MakeMethods::Emulator::Singleton->instance(); + + # returns same instance + my $two = Class::MakeMethods::Emulator::Singleton->instance(); + + +=head1 COMPATIBILITY + +This module emulates the functionality of Class::Singleton, using Class::MakeMethods to generate similar methods. + +You may use it directly, as shown in the SYNOPSIS above, + +Furthermore, you may call C<use Class::MakeMethods::Emulator::Singleton '-take_namespace';> to alias the Class::Singleton namespace to this package, and subsequent calls to the original package will be transparently handled by this emulator. To remove the emulation aliasing, call C<use Class::MakeMethods::Emulator::Singleton '-release_namespace'>. + +B<Caution:> This affects B<all> subsequent uses of Class::Singleton in your program, including those in other modules, and might cause unexpected effects. + + +=head1 DESCRIPTION + +A Singleton describes an object class that can have only one instance +in any system. An example of a Singleton might be a print spooler +or system registry. This module implements a Singleton class from +which other classes can be derived. By itself, the Class::Singleton +module does very little other than manage the instantiation of a +single object. In deriving a class from Class::Singleton, your +module will inherit the Singleton instantiation method and can +implement whatever specific functionality is required. + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L<Class::Singleton> for documentation of the original module. + +For a description and discussion of the Singleton class, see +"Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-201-63361-2. + +See L<Class::MakeMethods::Hash/new> and L<Class::MakeMethods::ClassVar/instance> for documentation of the created methods. + +=cut diff --git a/lib/Class/MakeMethods/Emulator/Struct.pm b/lib/Class/MakeMethods/Emulator/Struct.pm new file mode 100644 index 0000000..4dad355 --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/Struct.pm @@ -0,0 +1,154 @@ +package Class::MakeMethods::Emulator::Struct; + +use strict; + +use Class::MakeMethods; + +use vars qw(@ISA @EXPORT); +require Exporter; +push @ISA, qw(Exporter); +@EXPORT = qw(struct); + +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + $self->export_to_level( 1, $self, @_ ); + } else { + &struct; + } +} + +######################################################################## + +my %type_map = ( + '$' => 'scalar', + '@' => 'array', + '%' => 'hash', + '_' => 'object', +); + +sub struct { + my ($class, @decls); + my $base_type = ref $_[1] ; + if ( $base_type eq 'HASH' ) { + $base_type = 'Standard::Hash'; + $class = shift; + @decls = %{shift()}; + _usage_error() if @_; + } + elsif ( $base_type eq 'ARRAY' ) { + $base_type = 'Standard::Array'; + $class = shift; + @decls = @{shift()}; + _usage_error() if @_; + } + else { + $base_type = 'Standard::Array'; + $class = (caller())[0]; + @decls = @_; + } + _usage_error() if @decls % 2 == 1; + + my @rewrite; + while ( scalar @decls ) { + my ($name, $type) = splice(@decls, 0, 2); + push @rewrite, $type_map{$type} + ? ( $type_map{$type} => { 'name'=>$name, auto_init=>1 } ) + : ( $type_map{'_'} => { 'name'=>$name, 'class'=>$type, auto_init=>1 } ); + } + Class::MakeMethods->make( + -TargetClass => $class, + -MakerClass => $base_type, + "new" => 'new', + @rewrite + ); +} + +sub _usage_error { + require Carp; + Carp::confess "struct usage error"; +} + +######################################################################## + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Emulator::Struct - Emulate Class::Struct + + +=head1 SYNOPSIS + + use Class::MakeMethods::Emulator::Struct; + + struct ( + simple => '$', + ordered => '@', + mapping => '%', + obj_ref => 'FooObject' + ); + + +=head1 DESCRIPTION + +This module emulates the functionality of Class::Struct by munging the provided field-declaration arguments to match those expected by Class::MakeMethods. + +It supports the same four types of accessors, the choice of array-based or hash-based objects, and the choice of installing methods in the current package or a specified target. + + +=head1 EXAMPLE + +The below three declarations create equivalent methods for a simple hash-based class with a constructor and four accessors. + + use Class::Struct; + struct ( + simple => '$', + ordered => '@', + mapping => '%', + obj_ref => 'FooObject' + ); + + use Class::MakeMethods::Emulator::Struct; + struct ( + simple => '$', + ordered => '@', + mapping => '%', + obj_ref => 'FooObject' + ); + + use Class::MakeMethods ( + -MakerClass => 'Standard::Array', + 'new' => 'new', + 'scalar' => 'simple', + 'array -auto_init 1' => 'ordered', + 'hash -auto_init 1' => 'mapping', + 'object -auto_init 1' => '-class FooObject obj_ref' + ); + +=head1 COMPATIBILITY + +This module aims to offer a "95% compatible" drop-in replacement for the core Class::Struct module for purposes of comparison and code migration. + +The C<class-struct.t> test for the core Class::Struct module is included with this package. The test is unchanged except for the a direct substitution of this emulator's name in the place of the core module. + +However, there are numerous internal differences between the methods generated by the original Class::Struct and this emulator, and some existing code may not work correctly without modification. + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L<Class::Struct> for documentation of the original module. + +See L<Class::MakeMethods::Standard::Hash> and L<Class::MakeMethods::Standard::Array> for documentation of the created methods. + +=cut + diff --git a/lib/Class/MakeMethods/Emulator/accessors.pm b/lib/Class/MakeMethods/Emulator/accessors.pm new file mode 100644 index 0000000..69c3bb8 --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/accessors.pm @@ -0,0 +1,122 @@ +package Class::MakeMethods::Emulator::accessors; + +$VERSION = '0.02'; + +use Class::MakeMethods::Emulator '-isasubclass'; +use Class::MakeMethods::Template::Hash '-isasubclass'; + +sub _emulator_target { 'accessors' } +sub _accessor_type { 'scalar --get_set_chain' } + +sub import { + my $class = shift; + + $class->_handle_namespace( $class->_emulator_target, $_[0] ) and shift; + + foreach ( @_ ) { + die "invalid accessor - $_" unless ( /\A[a-z]\w+\z/i and + $_ ne 'DESTROY' and $_ ne 'AUTOLOAD' ) + } + + $class->make($class->_accessor_type => [@_]); +} + +######################################################################## + +package Class::MakeMethods::Emulator::accessors::chained; +@ISA = 'Class::MakeMethods::Emulator::accessors'; +$INC{'Class/MakeMethods/Emulator/accessors/chained.pm'} = + $INC{'Class/MakeMethods/Emulator/accessors.pm'}; + +sub _emulator_target { 'accessors::chained' } +sub _accessor_type { 'scalar --get_set_chain' } + +######################################################################## + +package Class::MakeMethods::Emulator::accessors::classic; +@ISA = 'Class::MakeMethods::Emulator::accessors'; +$INC{'Class/MakeMethods/Emulator/accessors/classic.pm'} = + $INC{'Class/MakeMethods/Emulator/accessors.pm'}; + +sub _emulator_target { 'accessors::classic' } +sub _accessor_type { 'scalar' } + +######################################################################## + +1; + +__END__ + + +=head1 NAME + +Class::MakeMethods::Emulator::accessors - Emulate the accessors module + + +=head1 SYNOPSIS + + package Foo; + use Class::MakeMethods::Emulator::accessors qw( foo bar baz ); + + my $obj = bless {}, 'Foo'; + + # generates chaining accessors: + $obj->foo( 'hello ' ) + ->bar( 'world' ) + ->baz( "!\n" ); + + print $obj->foo, $obj->bar, $obj->baz; + +This module also defines subpackages for the classic and chaining subclasses: + + package Bar; + use Class::MakeMethods::Emulator::accessors; + use Class::MakeMethods::Emulator::accessors::classic qw( foo bar baz ); + + my $obj = bless {}, 'Bar'; + + # always return the current value, even on set: + $obj->foo( 'hello ' ) if $obj->bar( 'world' ); + + print $obj->foo, $obj->bar, $obj->baz( "!\n" ); + + +=head1 DESCRIPTION + +This module emulates the functionality of the accessors module, using +Class::MakeMethods to generate similar methods. + +In particular, the following lines are equivalent: + + use accessors 'foo'; + use Class::MakeMethods::Template::Hash 'scalar --get_set_chain' => 'foo'; + + use accessors::chained 'foo'; + use Class::MakeMethods::Template::Hash 'scalar --get_set_chain' => 'foo'; + + use accessors::classic 'foo'; + use Class::MakeMethods::Template::Hash 'scalar' => 'foo'; + +You may use this module directly, as shown in the SYNOPSIS above, + +Furthermore, you may call C<use Class::MakeMethods::Emulator::accessors +'-take_namespace';> to alias the accessors namespace to this package, +and subsequent calls to the original package will be transparently +handled by this emulator. To remove the emulation aliasing, call +C<use Class::MakeMethods::Emulator::accessors '-release_namespace'>. +The same mechanism is also available for the classic and chained subclasses. + +B<Caution:> This affects B<all> subsequent uses of the accessors module in +your program, including those in other modules, and might cause +unexpected effects. + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L<accessors> for documentation of the original module. + +=cut diff --git a/lib/Class/MakeMethods/Emulator/mcoder.pm b/lib/Class/MakeMethods/Emulator/mcoder.pm new file mode 100644 index 0000000..84ef034 --- /dev/null +++ b/lib/Class/MakeMethods/Emulator/mcoder.pm @@ -0,0 +1,116 @@ +package Class::MakeMethods::Emulator::mcoder; + +$VERSION = '0.05'; + +use Class::MakeMethods::Emulator '-isasubclass'; +use Class::MakeMethods::Template '-isasubclass'; + +######################################################################## + +sub import { + my $class = shift; + ( my $target = $class ) =~ s/^Class::MakeMethods::Emulator:://; + $class->_handle_namespace( $target, $_[0] ) and shift; + $class->make( @_ ) if ( scalar @_ ); +} + + +sub new { 'Template::Hash::new --with_values' } +sub proxy { 'Template::Universal:forward_methods -target' } +sub generic { { '-import' => { 'Template::Hash:scalar' => '*' } } } +sub get { { interface => { default => { '*' =>'get' } } } } +sub set { { interface => { default => { 'set_*' =>'set' } } } } +sub undef { { interface => { default => { 'undef_*' =>'clear' } } } } +sub delete { { interface => { default => { 'delete_*'=>'hash_delete' } } } } +sub bool_set { { interface => { default => { 'set_*' =>'set_value' } }, + '-import' => { 'Template::Hash:boolean' => '*' } } } +sub bool_unset { { interface => { default => { 'unset_*' =>'clear' } } } } +sub calculated { { interface => { default => { '*' =>'get_init' } }, + params => { init_method=>'_calculate_*' } } } + +######################################################################## + +foreach my $type ( qw( new get set proxy calculated ) ) { + $INC{"Class/MakeMethods/Emulator/mcoder/$type.pm"} = + $INC{"mcoder/$type.pm"} = __FILE__; + *{__PACKAGE__ . "::${type}::import"} = sub { + (shift) and (__PACKAGE__)->make( $type => [ @_ ] ) + }; +} + +######################################################################## + +1; + +__END__ + +package Class::MakeMethods::Emulator::mcoder::get; +@ISA = 'Class::MakeMethods::Emulator::mcoder'; +$INC{"Class/MakeMethods/Emulator/mcoder/get.pm"} = __FILE__; +sub import { goto &Class::MakeMethods::Emulator::mcoder::sub_import } + +package Class::MakeMethods::Emulator::mcoder::set; +@ISA = 'Class::MakeMethods::Emulator::mcoder'; +$INC{"Class/MakeMethods/Emulator/mcoder/set.pm"} = __FILE__; +sub import { goto &Class::MakeMethods::Emulator::mcoder::sub_import } + +package Class::MakeMethods::Emulator::mcoder::proxy; +@ISA = 'Class::MakeMethods::Emulator::mcoder'; +$INC{"Class/MakeMethods/Emulator/mcoder/proxy.pm"} = __FILE__; +sub import { goto &Class::MakeMethods::Emulator::mcoder::sub_import } + + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Emulator::mcoder - Emulate the mcoder module + + +=head1 SYNOPSIS + + package MyClass; + + use Class::MakeMethods::Emulator::mcoder + [qw(get set)] => [qw(color sound height)], + proxy => [qw(runner run walk stop)], + calculated => weight; + + sub _calculate_weight { shift->ask_weight } + + +=head1 DESCRIPTION + +This module emulates the functionality of the mcoder module, using +Class::MakeMethods to generate similar methods. + +For example, the following lines are equivalent: + + use mcoder 'get' => 'foo'; + use mcoder::get 'foo'; + use Class::MakeMethods::Template::Hash 'scalar --get' => 'foo'; + +You may use this module directly, as shown in the SYNOPSIS above, +or you may call C<use Class::MakeMethods::Emulator::mcoder +'-take_namespace';> to alias the mcoder namespace to this package, +and subsequent calls to the original package will be transparently +handled by this emulator. To remove the emulation aliasing, call +C<use Class::MakeMethods::Emulator::mcoder '-release_namespace'>. +The same mechanism is also available for the "sugar" subclasses. + +B<Caution:> This affects B<all> subsequent uses of the mcoder module in +your program, including those in other modules, and might cause +unexpected effects. + + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Emulator> for more about this family of subclasses. + +See L< mcoder> for documentation of the original module. + +=cut |