diff options
Diffstat (limited to 'lib/Class/MakeMethods/Template')
| -rw-r--r-- | lib/Class/MakeMethods/Template/Array.pm | 102 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Class.pm | 103 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/ClassInherit.pm | 144 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/ClassName.pm | 330 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/ClassVar.pm | 178 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Flyweight.pm | 43 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Generic.pm | 2349 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Global.pm | 97 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Hash.pm | 229 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Inheritable.pm | 154 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/InsideOut.pm | 218 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/PackageVar.pm | 168 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Ref.pm | 207 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Scalar.pm | 80 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Static.pm | 41 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Struct.pm | 41 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/StructBuiltin.pm | 148 | ||||
| -rw-r--r-- | lib/Class/MakeMethods/Template/Universal.pm | 415 |
18 files changed, 5047 insertions, 0 deletions
diff --git a/lib/Class/MakeMethods/Template/Array.pm b/lib/Class/MakeMethods/Template/Array.pm new file mode 100644 index 0000000..0d2ab2d --- /dev/null +++ b/lib/Class/MakeMethods/Template/Array.pm @@ -0,0 +1,102 @@ +package Class::MakeMethods::Template::Array; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.00; +use Carp; + +=head1 NAME + +Class::MakeMethods::Template::Array - Methods for manipulating positional values in arrays + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +=cut + +use vars qw( %ClassInfo ); + +sub generic { + { + 'params' => { + 'array_index' => undef, + }, + 'code_expr' => { + _VALUE_ => '_SELF_->[_STATIC_ATTR_{array_index}]', + '-import' => { 'Template::Generic:generic' => '*' }, + _EMPTY_NEW_INSTANCE_ => 'bless [], _SELF_CLASS_', + _SET_VALUES_FROM_HASH_ => 'while ( scalar @_ ) { local $_ = shift(); $self->[ _BFP_FROM_NAME_{ $_ } ] = shift() }' + }, + 'behavior' => { + '-init' => sub { + my $m_info = $_[0]; + + # If we're the first one, + if ( ! $ClassInfo{$m_info->{target_class}} ) { + # traverse inheritance hierarchy, looking for fields to inherit + my @results; + no strict 'refs'; + my @sources = @{"$m_info->{target_class}\::ISA"}; + while ( my $class = shift @sources ) { + next unless exists $ClassInfo{ $class }; + push @sources, @{"$class\::ISA"}; + if ( scalar @results ) { + Carp::croak "Too many inheritances of fields"; + } + push @results, @{$ClassInfo{$class}}; + } + $ClassInfo{$m_info->{target_class}} = \@sources; + } + + my $class_info = $ClassInfo{$m_info->{target_class}}; + if ( ! defined $m_info->{array_index} ) { + foreach ( 0..$#$class_info ) { + if ( $class_info->[$_] eq $m_info->{'name'} ) { + $m_info->{array_index} = $_; last } + } + if ( ! defined $m_info->{array_index} ) { + push @ $class_info, $m_info->{'name'}; + $m_info->{array_index} = $#$class_info; + } + } + + return; + }, + }, + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic should be supported: + + scalar + string + number + boolean + bits (?) + array + hash + tiedhash (?) + hash_of_arrays (?) + object + instance + array_of_objects (?) + code + code_or_scalar (?) + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a ? above have not been tested sufficiently; please inform the author if they do not function as you would expect. + +=cut + +######################################################################## + +1; diff --git a/lib/Class/MakeMethods/Template/Class.pm b/lib/Class/MakeMethods/Template/Class.pm new file mode 100644 index 0000000..c846709 --- /dev/null +++ b/lib/Class/MakeMethods/Template/Class.pm @@ -0,0 +1,103 @@ +package Class::MakeMethods::Template::Class; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; +use Carp; + +=head1 NAME + +Class::MakeMethods::Template::Class - Associate information with a package + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Class ( + scalar => [ 'foo' ] + ); + + package main; + + MyObject->foo('bar') + print MyObject->foo(); + +=head1 DESCRIPTION + +These meta-methods provide access to class-specific values. They are similar to Static, except that each subclass has separate values. + +=cut + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'modifier' => { + }, + 'code_expr' => { + '_VALUE_' => '_ATTR_{data}->{_SELF_CLASS_}', + }, + } +} + +######################################################################## + +=head2 Class:scalar + +Creates methods to handle a scalar variable in the declaring package. + +See the documentation on C<Generic:scalar> for interfaces and behaviors. + +=cut + +######################################################################## + +=head2 Class:array + +Creates methods to handle a array variable in the declaring package. + +See the documentation on C<Generic:array> for interfaces and behaviors. + +=cut + +sub array { + { + '-import' => { + 'Template::Generic:array' => '*', + }, + 'modifier' => { + '-all' => q{ _REF_VALUE_ or @{_ATTR_{data}->{_SELF_CLASS_}} = (); * }, + }, + 'code_expr' => { + '_VALUE_' => '\@{_ATTR_{data}->{_SELF_CLASS_}}', + }, + } +} + +######################################################################## + +=head2 Class:hash + +Creates methods to handle a hash variable in the declaring package. + +See the documentation on C<Generic:hash> for interfaces and behaviors. + +=cut + +sub hash { + { + '-import' => { + 'Template::Generic:hash' => '*', + }, + 'modifier' => { + '-all' => q{ _REF_VALUE_ or %{_ATTR_{data}->{_SELF_CLASS_}} = (); * }, + }, + 'code_expr' => { + '_VALUE_' => '\%{_ATTR_{data}->{_SELF_CLASS_}}', + }, + } +} + +1; diff --git a/lib/Class/MakeMethods/Template/ClassInherit.pm b/lib/Class/MakeMethods/Template/ClassInherit.pm new file mode 100644 index 0000000..9c61393 --- /dev/null +++ b/lib/Class/MakeMethods/Template/ClassInherit.pm @@ -0,0 +1,144 @@ +=head1 NAME + +Class::MakeMethods::Template::ClassInherit - Overridable class data + +=head1 SYNOPSIS + + package MyClass; + + use Class::MakeMethods( 'Template::ClassInherit:scalar' => 'foo' ); + # We now have an accessor method for an "inheritable" scalar value + + package main; + + MyClass->foo( 'Foozle' ); # Set a class-wide value + print MyClass->foo(); # Retrieve class-wide value + ... + + package MySubClass; + @ISA = 'MyClass'; + + print MySubClass->foo(); # Intially same as superclass, + MySubClass->foo('Foobar'); # but overridable per subclass/ + +=head1 DESCRIPTION + +The MakeMethods subclass provides accessor methods that search an inheritance tree to find a value. This allows you to set a shared or default value for a given class, and optionally override it in a subclass. + +=cut + +######################################################################## + +package Class::MakeMethods::Template::ClassInherit; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; +use Carp; + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'modifier' => { + '-all' => [ q{ + _INIT_VALUE_CLASS_ + * + } ], + }, + 'code_expr' => { + '_VALUE_CLASS_' => '$_value_class', + '_INIT_VALUE_CLASS_' => q{ + my _VALUE_CLASS_; + for ( my @_INC_search = _SELF_CLASS_; scalar @_INC_search; ) { + _VALUE_CLASS_ = shift @_INC_search; + last if ( exists _ATTR_{data}->{_VALUE_CLASS_} ); + no strict 'refs'; + unshift @_INC_search, @{"_VALUE_CLASS_\::ISA"}; + } + }, + '_VALUE_' => '_ATTR_{data}->{_VALUE_CLASS_}', + '_GET_VALUE_' => q{ _ATTR_{data}->{_VALUE_CLASS_} }, + '_SET_VALUE_{}' => q{ ( _VALUE_CLASS_ = _SELF_CLASS_ and _ATTR_{data}->{_VALUE_CLASS_} = * ) }, + }, + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic should all be supported: + + scalar + string + string_index (?) + number + boolean + bits (?) + array (*) + hash (*) + tiedhash (?) + hash_of_arrays (?) + object (?) + instance (?) + array_of_objects (?) + code (?) + code_or_scalar (?) + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a * above are specifically defined in this package, whereas the others are formed automatically by the interaction of this package's generic settings with the code templates provided by the Generic superclass. + +The items marked with a ? above have not been tested sufficiently; please inform the author if they do not function as you would expect. + +=cut + +sub array { + { + '-import' => { + 'Template::Generic:array' => '*', + }, + 'modifier' => { + '-all' => [ q{ _VALUE_ ||= []; * } ], + }, + 'code_expr' => { + '_VALUE_' => '\@{_ATTR_{data}->{_SELF_CLASS_}}', + }, + } +} + +sub hash { + { + '-import' => { + 'Template::Generic:hash' => '*', + }, + 'modifier' => { + '-all' => [ q{ _VALUE_ ||= {}; * } ], + }, + 'code_expr' => { + '_VALUE_' => '\%{_ATTR_{data}->{_SELF_CLASS_}}', + }, + } +} + +######################################################################## + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for more about this family of subclasses. + +See L<Class::MakeMethods::Template::Generic> for information about the various accessor interfaces subclassed herein. + +If you just need scalar accessors, see L<Class::Data::Inheritable> for a very elegant and efficient implementation. + +=cut + +######################################################################## + +1; diff --git a/lib/Class/MakeMethods/Template/ClassName.pm b/lib/Class/MakeMethods/Template/ClassName.pm new file mode 100644 index 0000000..c37433f --- /dev/null +++ b/lib/Class/MakeMethods/Template/ClassName.pm @@ -0,0 +1,330 @@ +package Class::MakeMethods::Template::ClassName; + +use Class::MakeMethods::Template '-isasubclass'; +$VERSION = 1.008; + +sub _diagnostic { &Class::MakeMethods::_diagnostic } + +######################################################################## +###### CLASS NAME MANIPULATIONS +######################################################################## + +=head1 NAME + +Class::MakeMethods::Template::ClassName - Access object's class + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::ClassName ( + subclass_name => [ 'type' ] + ); + ... + package main; + my $object = MyObject->new; + + $object->type('Foo') + # reblesses object to MyObject::Foo subclass + + print $object->type(); + # prints "Foo". + +=head1 DESCRIPTION + +These method types access or change information about the class an object is associated with. + +=head2 class_name + +Called without arguments, returns the class name. + +If called with an argument, reblesses object into that class. +If the class doesn't already exist, it will be created. + +=head2 subclass_name + +Called without arguments, returns the subclass name. + +If called with an argument, reblesses object into that subclass. +If the subclass doesn't already exist, it will be created. + +The subclass name is written as follows: + +=over 4 + +=item * + +if it's the original, defining class: empty + +=item * + +if its a a package within the namespace of the original: the distingushing name within that namespace, without leading C<::> + +=item * + +if it's a package elsewhere: the full name with leading C<::> + +=back + +=cut + +# $subclass = _pack_subclass( $base, $pckg ); +sub _pack_subclass { + my $base = shift; + my $pckg = shift; + + ( $pckg eq $base ) ? '' : + ( $pckg =~ s/^\Q$base\E\:\:// ) ? $pckg : + "::$pckg"; +} + +# $pckg = _unpack_subclass( $base, $subclass ); +sub _unpack_subclass { + my $base = shift; + my $subclass = shift; + + ! $subclass ? $base : + ( $subclass =~ s/^::// ) ? $subclass : + "$base\::$subclass"; +} + +# $pckg = _require_class( $package ); +sub _require_class { + my $package = shift; + + no strict 'refs'; + unless ( @{$package . '::ISA'} ) { + (my $file = $package . '.pm' ) =~ s|::|/|go; + local $SIG{__DIE__} = sub { die @_ }; + # warn "Auto-requiring package $package \n"; + eval { require $file }; + if ( $@ ) { _diagnostic('mm_package_fail', $package, $@) } + } + + return $package; +} + +# $pckg = _provide_class( $base, $package ); +sub _provide_class { + my $base = shift; + my $package = shift; + + # If the subclass hasn't been created yet, do so. + no strict 'refs'; + unless ( scalar @{$package . '::ISA'} ) { + # warn "Auto-vivifying $base subclass $package\n"; + @{$package . '::ISA'} = ( $base ); + } + + return $package; +} + +sub class_name { + { + 'interface' => { + default => 'autocreate', + autocreate => { '*'=>'autocreate' }, + require => { '*'=>'require' }, + }, + 'behavior' => { + 'autocreate' => q{ + if ( ! scalar @_ ) { + _CLASS_GET_ + } else { + _CLASS_PROVIDE_ + } + }, + 'require' => q{ + if ( ! scalar @_ ) { + _CLASS_GET_ + } else { + _CLASS_REQUIRE_ + } + }, + }, + 'code_expr' => { + _CLASS_GET_ => q{ + my $class = ref $self || $self; + }, + _CLASS_REQUIRE_ => q{ + my $class = Class::MakeMethods::Template::ClassName::_require_class( shift() ); + _BLESS_AND_RETURN_ + }, + _CLASS_PROVIDE_ => q{ + my $class = Class::MakeMethods::Template::ClassName::_provide_class( + $m_info->{'target_class'}, shift() ); + _BLESS_AND_RETURN_ + }, + _BLESS_AND_RETURN_ => q{ + bless $self, $class if ( ref $self ); + return $class; + }, + }, + } +} + +sub subclass_name { + { + '-import' => { + 'Template::ClassName:class_name' => '*', + }, + 'code_expr' => { + _CLASS_GET_ => q{ + my $class = ref $self || $self; + Class::MakeMethods::Template::ClassName::_pack_subclass( $m_info->{'target_class'}, $class ) + }, + _CLASS_REQUIRE_ => q{ + my $subclass = Class::MakeMethods::Template::ClassName::_unpack_subclass( + $m_info->{'target_class'}, shift() ); + my $class = Class::MakeMethods::Template::ClassName::_require_class($subclass); + _BLESS_AND_RETURN_ + }, + _CLASS_PROVIDE_ => q{ + my $subclass = Class::MakeMethods::Template::ClassName::_unpack_subclass( + $m_info->{'target_class'}, shift() ); + my $class = Class::MakeMethods::Template::ClassName::_provide_class( + $m_info->{'target_class'}, $subclass ); + _BLESS_AND_RETURN_ + }, + }, + } +} + + +######################################################################## +### CLASS_REGISTRY + +=head2 static_hash_classname + +Provides a shared hash mapping keys to class names. + + class_registry => [ qw/ foo / ] + +Takes a single string or a reference to an array of strings as its argument. +For each string, creates a new anonymous hash and associated accessor methods +that will map scalar values to classes in the calling package's subclass +hiearchy. + +The accessor methods provide an interface to the hash as illustrated below. +Note that several of these functions operate quite differently depending on the +number of arguments passed, or the context in which they are called. + +=over 4 + +=item @indexes = $class_or_ref->x; + +Returns the scalar values that are indexes associated with this class, or the class of this object. + +=item $class = $class_or_ref->x( $index ); + +Returns the class name associated with the provided index value. + +=item @classes = $class_or_ref->x( @indexes ); + +Returns the associated classes for each index in order. + +=item @all_indexes = $class_or_ref->x_keys; + +Returns a list of the indexes defined for this registry. + +=item @all_classes = $class_or_ref->x_values; + +Returns a list of the classes associated with this registry. + +=item @all_classes = $class_or_ref->unique_x_values; + +Returns a list of the classes associated with this registry, with no more than one occurance of any value. + +=item %mapping = $class_or_ref->x_hash; + +Return the key-value pairs used to store this attribute + +=item $mapping_ref = $class_or_ref->x_hash; + +Returns a reference to the hash used for the mapping. + +=item $class_or_ref->add_x( @indexes ); + +Adds an entry in the hash for each of the provided indexes, mapping it to this class, or the class of this object. + +=item $class_or_ref->clear_x; + +Removes those entries from the hash whose values are this class, or the class of this object. + +=item $class_or_ref->clear_xs( @indexes ); + +Remove all entries from the hash. + +=back + +=cut + +sub static_hash_classname { + { + '-import' => { + 'Template::Static:hash' => '*', + }, + 'params' => { 'instance' => {} }, + 'interface' => { + default => { + '*'=>'get_classname', + 'add_*'=>'add_classname', + 'clear_*'=>'drop_classname', + '*_keys'=>'keys', + '*_hash'=>'get', + '*_values'=>'values', + 'clear_*s'=>'clear', + 'unique_*_values'=>'unique_values', + }, + }, + 'behavior' => { + 'get_classname' => sub { my $m_info = $_[0]; sub { + my $self = shift; + my $class = ( ref($self) || $self ); + + defined $m_info->{'instance'} or $m_info->{'instance'} = {}; + my $hash = $m_info->{'instance'}; + + if ( ! scalar @_ ) { + my @keys = grep { $hash->{$_} eq $class } keys %$hash; + return wantarray ? @keys : $keys[0]; + } elsif (scalar @_ == 1) { + return $hash->{ shift() }; + } else { + return @{$hash}{ @_ }; + } + }}, + 'add_classname' => sub { my $m_info = $_[0]; sub { + my $self = shift; + my $class = ( ref($self) || $self ); + + defined $m_info->{'instance'} or $m_info->{'instance'} = {}; + my $hash = $m_info->{'instance'}; + + foreach ( @_ ) { $hash->{$_} = $class } + }}, + 'drop_classname' => sub { my $m_info = $_[0]; sub { + my $self = shift; + my $class = ( ref($self) || $self ); + + defined $m_info->{'instance'} or $m_info->{'instance'} = {}; + my $hash = $m_info->{'instance'}; + + foreach ( grep { $hash->{$_} eq $class } keys %$hash ){ + delete $hash{$_} + } + }}, + }, + } +} + +######################################################################## + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for information about this family of subclasses. + +=cut + +1; diff --git a/lib/Class/MakeMethods/Template/ClassVar.pm b/lib/Class/MakeMethods/Template/ClassVar.pm new file mode 100644 index 0000000..a5a2478 --- /dev/null +++ b/lib/Class/MakeMethods/Template/ClassVar.pm @@ -0,0 +1,178 @@ +package Class::MakeMethods::Template::ClassVar; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; +use Carp; + +=head1 NAME + +Class::MakeMethods::Template::ClassVar - Static methods with subclass variation + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::ClassVar ( + scalar => [ 'foo' ] + ); + + package main; + + MyObject->foo('bar') + print MyObject->foo(); + + $MyObject::foo = 'bazillion'; + print MyObject->foo(); + +=head1 DESCRIPTION + +These meta-methods provide access to package (class global) variables, +with the package determined at run-time. + +This is basically the same as the PackageVar meta-methods, except +that PackageVar methods find the named variable in the package that +defines the method, while ClassVar methods use the package the object +is blessed into. As a result, subclasses will each store a distinct +value for a ClassVar method, but will share the same value for a +PackageVar or Static method. + +B<Common Parameters>: The following parameters are defined for ClassVar meta-methods. + +=over 4 + +=item variable + +The name of the variable to store the value in. Defaults to the same name as the method. + +=back + +=cut + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'params' => { + 'variable' => '*' + }, + 'modifier' => { + '-all' => [ q{ no strict; * } ], + }, + 'code_expr' => { + '_VALUE_' => '${_SELF_CLASS_."::"._ATTR_{variable}}', + }, + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic should all be supported: + + scalar + string + string_index (?) + number + boolean + bits (?) + array (*) + hash (*) + tiedhash (?) + hash_of_arrays (?) + object (?) + instance (?) + array_of_objects (?) + code (?) + code_or_scalar (?) + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a * above are specifically defined in this package, whereas the others are formed automatically by the interaction of this package's generic settings with the code templates provided by the Generic superclass. + +The items marked with a ? above have not been tested sufficiently; please inform the author if they do not function as you would expect. + +=cut + +######################################################################## + +sub array { + { + '-import' => { + 'Template::Generic:array' => '*', + }, + 'modifier' => { + '-all' => q{ no strict; _ENSURE_REF_VALUE_; * }, + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ + _REF_VALUE_ or @{_SELF_CLASS_."::"._ATTR_{variable}} = (); + }, + '_VALUE_' => '(\@{_SELF_CLASS_."::"._ATTR_{variable}})', + }, + } +} + +######################################################################## + +sub hash { + { + '-import' => { + 'Template::Generic:hash' => '*', + }, + 'modifier' => { + '-all' => q{ no strict; _ENSURE_REF_VALUE_; * }, + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ + _REF_VALUE_ or %{_SELF_CLASS_."::"._ATTR_{variable}} = (); + }, + '_VALUE_' => '(\%{_SELF_CLASS_."::"._ATTR_{variable}})', + }, + } +} + +######################################################################## + +=head2 vars + +This rewrite rule converts package variable names into ClassVar methods of the equivalent data type. + +Here's an example declaration: + + package MyClass; + + use Class::MakeMethods::Template::ClassVar ( + vars => '$VERSION @ISA' + ); + +MyClass now has methods that get and set the contents of its $MyClass::VERSION and @MyClass::ISA package variables: + + MyClass->VERSION( 2.4 ); + MyClass->push_ISA( 'Exporter' ); + +Subclasses can use these methods to adjust their own variables: + + package MySubclass; + MySubclass->MyClass::push_ISA( 'MyClass' ); + MySubclass->VERSION( 1.0 ); + +=cut + +sub vars { + my $mm_class = shift; + my @rewrite = map [ "Template::ClassVar:$_" ], qw( scalar array hash ); + my %rewrite = ( '$' => 0, '@' => 1, '%' => 2 ); + while (@_) { + my $name = shift; + my $data = shift; + $data =~ s/\A(.)//; + push @{ $rewrite[ $rewrite{ $1 } ] }, { 'name'=>$name, 'variable'=>$data }; + } + return @rewrite; +} + +1; diff --git a/lib/Class/MakeMethods/Template/Flyweight.pm b/lib/Class/MakeMethods/Template/Flyweight.pm new file mode 100644 index 0000000..33f44ed --- /dev/null +++ b/lib/Class/MakeMethods/Template/Flyweight.pm @@ -0,0 +1,43 @@ +package Class::MakeMethods::Template::Flyweight; + +use Class::MakeMethods::Template::InsideOut '-isasubclass'; + +$VERSION = 1.008; + +sub new { { '-import' => { 'Template::Scalar:new' => '*' } } } + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Template::Flyweight - Deprecated name for InsideOut + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::InsideOut ( + new => [ 'new' ] + scalar => [ 'foo', 'bar' ] + ); + + package main; + + my $obj = MyObject->new( foo => "Foozle", bar => "Bozzle" ); + print $obj->foo(); # Prints Foozle + $obj->bar("Bamboozle"); # Sets $obj->{bar} + +=head1 DESCRIPTION + +Earlier versions of this package included a package named Class::MakeMethods::Template::Flyweight. + +However, in hindsight, this name was poorly chosen, as it suggests that the Flyweight object design pattern is being used, when the functionality is more akin to what's sometimes known as "inside-out objects." + +This functionality is now provided by Class::MakeMethods::Template::InsideOut, of which this is an almost-empty subclass retained to provide backwards compatibility. + +=head1 SEE ALSO + +L<Class::MakeMethods::Template::InsideOut>. + +=cut
\ No newline at end of file diff --git a/lib/Class/MakeMethods/Template/Generic.pm b/lib/Class/MakeMethods/Template/Generic.pm new file mode 100644 index 0000000..368f21f --- /dev/null +++ b/lib/Class/MakeMethods/Template/Generic.pm @@ -0,0 +1,2349 @@ +=head1 NAME + +Class::MakeMethods::Template::Generic - Templates for common meta-method types + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods ( + 'Template::Hash:new' => [ 'new' ], + 'Template::Hash:scalar' => [ 'foo' ] + 'Template::Static:scalar' => [ 'bar' ] + ); + + package main; + + my $obj = MyObject->new( foo => "Foozle", bar => "Bozzle" ); + print $obj->foo(); + $obj->bar("Bamboozle"); + +=head1 DESCRIPTION + +This package provides a variety of abstract interfaces for constructors +and accessor methods, which form a common foundation for meta-methods +provided by the Hash, Scalar, Flyweight, Static, PackageVar, and +ClassVar implementations. + +Generally speaking, the Generic meta-methods define calling interfaces +and behaviors which are bound to differently scoped data by each +of those subclasses. + +=cut + +######################################################################## + +package Class::MakeMethods::Template::Generic; + +use Class::MakeMethods::Template '-isasubclass'; + +$VERSION = 1.008; +use strict; +use Carp; + +# use AutoLoader 'AUTOLOAD'; + +######################################################################## + +sub generic { + { + 'params' => { + }, + 'modifier' => { + '-import' => { 'Template::Universal:generic' => '*' }, + }, + 'code_expr' => { + '-import' => { 'Template::Universal:generic' => '*' }, + '_VALUE_' => undef, + '_REF_VALUE_' => q{ _VALUE_ }, + '_GET_VALUE_' => q{ _VALUE_ }, + '_SET_VALUE_{}' => q{ ( _VALUE_ = * ) }, + '_PROTECTED_SET_VALUE_{}' => q{ (_ACCESS_PROTECTED_ and _SET_VALUE_{*}) }, + '_PRIVATE_SET_VALUE_{}' => q{ ( _ACCESS_PRIVATE_ and _SET_VALUE_{*} ) }, + }, + } +} + +# 1; + +# __END__ + +######################################################################## + +=head2 new Constructor + +There are several types of hash-based object constructors to choose from. + +Each of these methods creates and returns a reference to a new +blessed instance. They differ in how their (optional) arguments +are interpreted to set initial values, and in how they operate when +called as class or instance methods. + +B<Interfaces>: The following interfaces are supported. + +=over 4 + +=item -with_values, + +Provides the with_values behavior. + +=item -with_init + +Provides the with_init behavior. + +=item -with_methods + +Provides the with_methods behavior. + +=item -new_and_init + +Provides the with_init behavior for I<*>, and the general purpose method_init behavior as an init method. + +=item -copy_with_values + +Provides the copy behavior. + +=back + +B<Behaviors>: The following types of constructor methods are available. + +=over 4 + +=item with_values + +Creates and blesses a new instance. + +If arguments are passed they are included in the instance, otherwise it will be empty. + +Returns the new instance. + +May be called as a class or instance method. + +=item with_methods + +Creates, blesses, and returns a new instance. + +The arguments are treated as a hash of method-name/argument-value +pairs, with each such pair causing a call C<$self-E<gt>name($value)>. + +=item with_init + +Creates and blesses a new instance, then calls a method named C<init>, +passing along any arguments that were initially given. + +Returns the new instance. + +The I<init>() method should be defined in the class declaring these methods. + +May be called as a class or instance method. + +=item and_then_init + +Creates a new instance using method-name/argument-value pairs, like C<with_methods>, but then calls a method named C<init> before returning the new object. The C<init> method does not receive any arguments. + +The I<init>() method should be defined in the class declaring these methods. + +=item instance_with_methods + +If called as a class method, creates, blesses, and returns a new +instance. If called as an object method, operates on and returns +the existing instance. + +Accepts name-value pair arguments, or a reference to hash of such +pairs, and calls the named method for each with the supplied value +as a single argument. (See the Universal method_init behavior for +more discussion of this pattern.) + +=item copy_with values + +Produce a copy of an instance. Can not be called as a class method. + +The copy is a *shallow* copy; any references will be shared by the +instance upon which the method is called and the returned newborn. + +If a list of key-value pairs is passed as arguments to the method, +they are added to the copy, overwriting any values with the same +key that may have been copied from the original. + +=item copy_with_methods + +Produce a copy of an instance. Can not be called as a class method. + +The copy is a *shallow* copy; any references will be shared by the +instance upon which the method is called and the returned newborn. + +Accepts name-value pair arguments, or a reference to hash of such +pairs, and calls the named method on the copy for each with the +supplied value as a single argument before the copy is returned. + +=item copy_instance_with_values + +If called as a class method, creates, blesses, and returns a new +instance. If called as an object method, produces and returns a +copy of an instance. + +The copy is a *shallow* copy; any references will be shared by the +instance upon which the method is called and the returned newborn. + +If a list of key-value pairs is passed as arguments to the method, +they are added to the copy, overwriting any values with the same +key that may have been copied from the original. + +=item copy_instance_with_methods + +If called as a class method, creates, blesses, and returns a new +instance. If called as an object method, produces and returns a +copy of an instance. + +The copy is a *shallow* copy; any references will be shared by the +instance upon which the method is called and the returned newborn. + +Accepts name-value pair arguments, or a reference to hash of such +pairs, and calls the named method on the copy for each with the supplied value as +a single argument before the copy is returned. + +=back + +B<Parameters>: The following parameters are supported: + +=over 4 + +=item init_method + +The name of the method to call after creating a new instance. Defaults to 'init'. + +=back + +=cut + +sub new { + { + '-import' => { + # 'Template::Generic:generic' => '*', + }, + 'interface' => { + default => 'with_methods', + with_values => 'with_values', + with_methods => 'with_methods', + with_init => 'with_init', + and_then_init => 'and_then_init', + new_and_init => { '*'=>'new_with_init', 'init'=>'method_init'}, + instance_with_methods => 'instance_with_methods', + copy => 'copy_with_values', + copy_with_values => 'copy_with_values', + copy_with_methods => 'copy_with_methods', + copy_instance_with_values => 'copy_instance_with_values', + copy_instance_with_methods => 'copy_instance_with_methods', + }, + 'behavior' => { + 'with_methods' => q{ + $self = _EMPTY_NEW_INSTANCE_; + _CALL_METHODS_FROM_HASH_ + return $self; + }, + 'with_values' => q{ + $self = _EMPTY_NEW_INSTANCE_; + _SET_VALUES_FROM_HASH_ + return $self; + }, + 'with_init' => q{ + $self = _EMPTY_NEW_INSTANCE_; + my $init_method = $m_info->{'init_method'} || 'init'; + $self->$init_method( @_ ); + return $self; + }, + 'and_then_init' => q{ + $self = _EMPTY_NEW_INSTANCE_; + _CALL_METHODS_FROM_HASH_ + my $init_method = $m_info->{'init_method'} || 'init'; + $self->$init_method(); + return $self; + }, + 'instance_with_methods' => q{ + $self = ref ($self) ? $self : _EMPTY_NEW_INSTANCE_; + _CALL_METHODS_FROM_HASH_ + return $self; + }, + 'copy_with_values' => q{ + @_ = ( %$self, @_ ); + $self = _EMPTY_NEW_INSTANCE_; + _SET_VALUES_FROM_HASH_ + return $self; + }, + 'copy_with_methods' => q{ + @_ = ( %$self, @_ ); + $self = _EMPTY_NEW_INSTANCE_; + _CALL_METHODS_FROM_HASH_ + return $self; + }, + 'copy_instance_with_values' => q{ + $self = bless { ( ref $self ? %$self : () ) }, _SELF_CLASS_; + _SET_VALUES_FROM_HASH_ + return $self; + }, + 'copy_instance_with_methods' => q{ + $self = bless { ref $self ? %$self : () }, _SELF_CLASS_; + _CALL_METHODS_FROM_HASH_ + return $self; + }, + }, + } +} + +######################################################################## + +=head2 scalar Accessor + +A generic scalar-value accessor meta-method which serves as an +abstraction for basic "get_set" methods and numerous related +interfaces + + use Class::MakeMethods -MakerClass => "...", + scalar => [ 'foo', 'bar' ]; + ... + $self->foo( 'my new foo value' ); + print $self->foo(); + +(Note that while you can use the scalar methods to store references to +various data structures, there are other meta-methods defined below that +may be more useful for managing references to arrays, hashes, and objects.) + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item get_set (default) + +Provides get_set method for I<*>. + +Example: Create method foo, which sets the value of 'foo' for this +instance if an argument is passed in, and then returns the value +whether or not it's been changed: + + use Class::MakeMethods -MakerClass => "...", + scalar => [ 'foo' ]; + +=item get_protected_set + +Provides an get_set accessor for I<*> that croaks if a new value +is passed in from a package that is not a subclass of the declaring +one. + +=item get_private_set + +Provides an get_set accessor for I<*> that croaks if a new value +is passed in from a package other than the declaring one. + +=item read_only + +Provides an accessor for I<*> that does not modify its value. (Its +initial value would have to be set by some other means.) + +=item eiffel + +Provides get behavior as I<*>, and set behavior as set_I<*>. + +Example: Create methods bar which returns the value of 'bar' for +this instance (takes no arguments), and set_bar, which sets the +value of 'bar' (no return): + + use Class::MakeMethods -MakerClass => "...", + scalar => [ --eiffel => 'bar' ]; + +=item java + +Provides get behavior as getI<*>, and set behavior as setI<*>. + +Example: Create methods getBaz which returns the value of 'Baz' +for this instance (takes no arguments), and setBaz, which sets the +value for this instance (no return): + + use Class::MakeMethods -MakerClass => "...", + scalar => [ --java => 'Baz' ]; + + +=item init_and_get + +Creates methods which cache their results in a hash key. + +Provides the get_init behavior for I<*>, and an delete behavior for clear_I<*>. +Specifies default value for init_method parameter of init_I<*>. + + +=item with_clear + +Provides get_set behavior for I<*>, and a clear_I<*> method. + +=back + + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get_set + +If no argument is provided, returns the value of the current instance. The value defaults to undef. + +If an argument is provided, it is stored as the value of the current +instance (even if the argument is undef), and that value is returned. + +Also available as get_protected_set and get_private_set, which are +available for public read-only access, but have access control +limitations. + +=item get + +Returns the value from the current instance. + +=item set + +Sets the value for the current instance. If called with no arguments, +the value is set to undef. Does not return a value. + +=item clear + +Sets value to undef. + +=item get_set_chain + +Like get_set, but if called with an argument, returns the object it was called on. This allows a series of mutators to be called as follows: + + package MyObject; + use Class::MakeMethods ( + 'Template::Hash:scalar --get_set_chain' => 'foo bar baz' + ); + ... + + my $obj = MyObject->new->foo('Foozle'); + $obj->bar("none")->baz("Brazil"); + print $obj->foo, $obj->bar, $obj->baz; + +=item get_set_prev + +Like get_set, but if called with an argument, returns the previous value before it was changed to the new one. + +=item get_init + +If the value is currently undefined, calls the init_method. Returns the value. + +=back + +B<Parameters>: The following parameters are supported: + +=over 4 + +=item init_method + +The name of a method to be called to initialize this meta-method. + +Only used by the get_init behavior. + +=back + +=cut + +sub scalar { + { + '-import' => { 'Template::Generic:generic' => '*' }, + 'interface' => { + default => 'get_set', + get_set => { '*'=>'get_set' }, + noclear => { '*'=>'get_set' }, + with_clear => { '*'=>'get_set', 'clear_*'=>'clear' }, + + read_only => { '*'=>'get' }, + get_private_set => 'get_private_set', + get_protected_set => 'get_protected_set', + + eiffel => { '*'=>'get', 'set_*'=>'set_return' }, + java => { 'get*'=>'get', 'set*'=>'set_return' }, + + init_and_get => { '*'=>'get_init', -params=>{ init_method=>'init_*' } }, + + }, + 'behavior' => { + 'get' => q{ _GET_VALUE_ }, + 'set' => q{ _SET_VALUE_{ shift() } }, + 'set_return' => q{ _BEHAVIOR_{set}; return }, + 'clear' => q{ _SET_VALUE_{ undef } }, + 'defined' => q{ defined _VALUE_ }, + + 'get_set' => q { + if ( scalar @_ ) { + _BEHAVIOR_{set} + } else { + _BEHAVIOR_{get} + } + }, + 'get_set_chain' => q { + if ( scalar @_ ) { + _BEHAVIOR_{set}; + return _SELF_ + } else { + _BEHAVIOR_{get} + } + }, + 'get_set_prev' => q { + my $value = _BEHAVIOR_{get}; + if ( scalar @_ ) { + _BEHAVIOR_{set}; + } + return $value; + }, + + 'get_private_set' => q{ + if ( scalar @_ ) { + _PRIVATE_SET_VALUE_{ shift() } + } else { + _BEHAVIOR_{get} + } + }, + 'get_protected_set' => q{ + if ( scalar @_ ) { + _PROTECTED_SET_VALUE_{ shift() } + } else { + _BEHAVIOR_{get} + } + }, + 'get_init' => q{ + if ( ! defined _VALUE_ ) { + my $init_method = _ATTR_REQUIRED_{'init_method'}; + _SET_VALUE_{ _SELF_->$init_method( @_ ) }; + } else { + _BEHAVIOR_{get} + } + }, + + }, + 'params' => { + new_method => 'new' + }, + } +} + +######################################################################## + +=head2 string Accessor + +A generic scalar-value accessor meta-method which serves as an +abstraction for basic "get_set" methods and numerous related +interfaces + + use Class::MakeMethods -MakerClass => "...", + string => [ 'foo', 'bar' ]; + ... + $self->foo( 'my new foo value' ); + print $self->foo(); + +This meta-method extends the scalar meta-method, and supports the same interfaces and parameters. + +However, it generally treats values as strings, and can not be used to store references. + +B<Interfaces>: In addition to those provided by C<scalar>, the following calling interfaces are available. + +=over 4 + +=item -get_concat + +Provides the get_concat behavior for I<*>, and a clear_I<*> method. + +Example: + + use Class::MakeMethods + get_concat => { name => 'words', join => ", " }; + + $obj->words('foo'); + $obj->words('bar'); + $obj->words() eq 'foo, bar'; + +=back + +B<Behaviors>: In addition to those provided by C<scalar>, the following types of accessor methods are available. + +=over 4 + +=item concat + +Concatenates the argument value with the existing value. + +=item get_concat + +Like get_set except sets do not clear out the original value, but instead +concatenate the new value to the existing one. + +=back + +B<Parameters>: In addition to those provided by C<scalar>, the following parameters are supported. + +=over 4 + +=item join + +If the join parameter is defined, each time the get_concat behavior +is invoked, it will glue its argument onto any existing value with +the join string as the separator. The join field is applied I<between> +values, not prior to the first or after the last. Defaults to undefined + +=back + +=cut + +sub string { + { + '-import' => { 'Template::Generic:scalar' => '*' }, + 'interface' => { + get_concat => { '*'=>'get_concat', 'clear_*'=>'clear', + -params=>{ 'join' => '' }, }, + }, + 'params' => { + 'return_value_undefined' => '', + }, + 'behavior' => { + 'get' => q{ + if ( defined( my $value = _GET_VALUE_) ) { + _GET_VALUE_; + } else { + _STATIC_ATTR_{return_value_undefined}; + } + }, + 'set' => q{ + my $new_value = shift(); + _SET_VALUE_{ "$new_value" }; + }, + 'concat' => q{ + my $new_value = shift(); + if ( defined( my $value = _GET_VALUE_) ) { + _SET_VALUE_{join( _STATIC_ATTR_{join}, $value, $new_value)}; + } else { + _SET_VALUE_{ "$new_value" }; + } + }, + 'get_concat' => q{ + if ( scalar @_ ) { + _BEHAVIOR_{concat} + } else { + _BEHAVIOR_{get} + } + }, + }, + } +} + +######################################################################## + +=head2 string_index + + string_index => [ qw / foo bar baz / ] + +Creates string accessor methods, like string above, but also +maintains a static hash index in which each object is stored under +the value of the field when the slot is set. + +This is a unique index, so only one object can have a given key. +If an object has a slot set to a value which another object is +already set to the object currently set to that value has that slot +set to undef and the new object will be put into the hash under +that value. + +Objects with undefined values are not stored in the index. + +Note that to free items from memory, you must clear these values! + +B<Methods>: + +=over 4 + +=item * + +The method find_x is defined which if called with any arguments +returns a list of the objects stored under those values in the +hash. Called with no arguments, it returns a reference to the hash. + +=back + +B<Profiles>: + +=over 4 + +=item * + +find_or_new + + 'string_index -find_or_new' => [ qw / foo bar baz / ] + +Just like string_index except the find_x method is defined to call the new +method to create an object if there is no object already stored under +any of the keys you give as arguments. + +=back + +=cut + +sub string_index { + ( { + '-import' => { 'Template::Generic:generic' => '*' }, + 'params' => { + 'new_method' => 'new', + }, + 'interface' => { + default => { '*'=>'get_set', 'clear_*'=>'clear', 'find_*'=>'find' }, + find_or_new=>{'*'=>'get_set', 'clear_*'=>'clear', 'find_*'=>'find_or_new'} + }, + 'code_expr' => { + _REMOVE_FROM_INDEX_ => q{ + if (defined ( my $old_v = _GET_VALUE_ ) ) { + delete _ATTR_{'index'}{ $old_v }; + } + }, + _ADD_TO_INDEX_ => q{ + if (defined ( my $new_value = _GET_VALUE_ ) ) { + if ( my $old_item = _ATTR_{'index'}{$new_value} ) { + # There's already an object stored under that value so we + # need to unset it's value. + # And maybe issue a warning? Or croak? + my $m_name = _ATTR_{'name'}; + $old_item->$m_name( undef ); + } + + # Put ourself in the index under that value + _ATTR_{'index'}{$new_value} = _SELF_; + } + }, + _INDEX_HASH_ => '_ATTR_{index}', + }, + 'behavior' => { + '-init' => [ sub { + my $m_info = $_[0]; + defined $m_info->{'index'} or $m_info->{'index'} = {}; + return; + } ], + 'get' => q{ + return _GET_VALUE_; + }, + 'set' => q{ + my $new_value = shift; + + _REMOVE_FROM_INDEX_ + + # Set our value to new + _SET_VALUE_{ $new_value }; + + _ADD_TO_INDEX_ + }, + 'get_set' => q{ + if ( scalar @_ ) { + _BEHAVIOR_{set} + } else { + _BEHAVIOR_{get} + } + }, + 'clear' => q{ + _REMOVE_FROM_INDEX_ + _SET_VALUE_{ undef }; + }, + 'find' => q{ + if ( scalar @_ ) { + return @{ _ATTR_{'index'} }{ @_ }; + } else { + return _INDEX_HASH_ + } + }, + 'find_or_new' => q{ + if ( scalar @_ ) { + my $class = _SELF_CLASS_; + my $new_method = _ATTR_REQUIRED_{'new_method'}; + my $m_name = _ATTR_{'name'}; + foreach (@_) { + next if defined _ATTR_{'index'}{$_}; + # create new instance and set its value; it'll add itself to index + $class->$new_method()->$m_name($_); + } + return @{ _ATTR_{'index'} }{ @_ }; + } else { + return _INDEX_HASH_ + } + }, + }, + } ) +} + +######################################################################## + +=head2 number Accessor + +A generic scalar-value accessor meta-method which serves as an +abstraction for basic "get_set" methods and numerous related +interfaces + + use Class::MakeMethods -MakerClass => "...", + string => [ 'foo', 'bar' ]; + ... + $self->foo( 23 ); + print $self->foo(); + +This meta-method extends the scalar meta-method, and supports the same interfaces and parameters. + +However, it generally treats values as numbers, and can not be used to store strings or references. + +B<Interfaces>: In addition to those provided by C<scalar>, the following calling interfaces are available. + +=over 4 + +=item -counter + +Provides the numeric get_set behavior for I<*>, and numeric I<*>_incr and I<*>_reset methods. + +=back + +B<Behaviors>: In addition to those provided by C<scalar>, the following types of accessor methods are available. + +=over 4 + +=item get_set + +The get_set behavior is similar to the default scalar behavior except that empty values are treated as zero. + +=item increment + +If no argument is provided, increments the I<hash_key> value by 1. +If an argument is provided, the value is incremented by that amount. +Returns the increased value. + +=item clear + +Sets the value to zero. + +=back + +=cut + +sub number { + { + '-import' => { 'Template::Generic:scalar' => '*' }, + 'interface' => { + counter => { '*'=>'get_set', '*_incr'=>'incr', '*_reset'=>'clear' }, + }, + 'params' => { + 'return_value_undefined' => 0, + }, + 'behavior' => { + 'get_set' => q{ + if ( scalar @_ ) { + local $_ = shift; + if ( defined $_ ) { + croak "Can't set _STATIC_ATTR_{name} to non-numeric value '$_'" + if ( /[^\+\-\,\d\.e]/ ); + s/\,//g; + } + _SET_VALUE_{ $_ } + } + defined( _GET_VALUE_ ) ? _GET_VALUE_ + : _STATIC_ATTR_{return_value_undefined} + }, + 'incr' => q{ + _VALUE_ ||= 0; + _VALUE_ += ( scalar @_ ? shift : 1 ) + }, + 'decr' => q{ + _VALUE_ ||= 0; + _VALUE_ -= ( scalar @_ ? shift : 1 ) + }, + }, + } +} + +######################################################################## + +=head2 boolean Accessor + +A generic scalar-value accessor meta-method which serves as an abstraction for basic "get_set" methods and numerous related interfaces + + use Class::MakeMethods -MakerClass => "...", + string => [ 'foo', 'bar' ]; + ... + $self->foo( 1 ); + print $self->foo(); + $self->clear_foo; + +This meta-method extends the scalar meta-method, and supports the +same interfaces and parameters. However, it generally treats values +as true-or-false flags, and can not be used to store strings, +numbers, or references. + +B<Interfaces>: + +=over 4 + +=item flag_set_clear (default) + +Provides the get_set behavior for I<*>, and set_I<*> and clear_I<*> methods to set the value to true or false. + +=back + +B<Behaviors>: In addition to those provided by C<scalar>, the following types of accessor methods are available. + +=over 4 + +=item get_set + +The get_set behavior is similar to the get_set scalar behavior +except that empty or false values are treated as zero, and true +values are treated as zero. + +=item set_true + +Sets the value to one. + +=item set_false + +Sets the value to zero. +=back + +=cut + +sub boolean { + { + '-import' => { 'Template::Generic:scalar' => '*' }, + 'interface' => { + default => {'*'=>'get_set', 'clear_*'=>'set_false', + 'set_*'=>'set_true'}, + flag_set_clear => {'*'=>'get_set', 'clear_*'=>'set_false', + 'set_*'=>'set_true'}, + }, + 'behavior' => { + 'get' => q{ _GET_VALUE_ || 0 }, + 'set' => q{ + if ( shift ) { + _BEHAVIOR_{set_true} + } else { + _BEHAVIOR_{set_false} + } + }, + 'set_true' => q{ _SET_VALUE_{ 1 } }, + 'set_false' => q{ _SET_VALUE_{ 0 } }, + 'set_value' => q{ + _SET_VALUE_{ scalar @_ ? shift : 1 } + }, + }, + } +} + +######################################################################## + +=head2 bits Accessor + +A generic accessor for bit-field values. + +The difference between 'Template::Generic:bits' and +'Template::Generic:boolean' is that all flags created with this +meta-method are stored in a single vector for space efficiency. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides get_set behavior for I<*>, a set_I<*> method which sets +the value to true and a clear_I<*> method which sets the value to +false. + +Also defines methods named bits, bit_fields, and bit_dump with the +behaviors below. These methods are shared across all of the boolean +meta-methods defined by a single class. + +=item class_methods + +. + +=back + +B<Basic Behaviors>: The following types of bit-level accessor methods are available. + +=over 4 + +=item get_set + +Returns the value of the named flag. If called with an argument, it first +sets the named flag to the truth-value of the argument. + +=item set_true + +Sets the value to true. + +=item set_false + +Sets the value to false. + +=back + +B<Group Methods>: The following types of methods manipulate the overall vector value. + +=over 4 + +=item bits + +Returns the vector containing all of the bit fields (remember however +that a vector containing all 0 bits is still true). + +=item bit_dump + +Returns a hash of the flag-name/flag-value pairs. + +=item bits_size + +Returns the number of bits that can fit into the current vector. + +=item bits_complement + +Returns the twos-complement of the vector. + +=item bit_pos_get + +Takes a single argument and returns the value of the bit stored in that position. + +=item bit_pos_set + +Takes two arguments and sets the bit stored in the position of the first argument to the value of the second argument. + +=back + +B<Class Methods>: The following types of class methods are available. + +=over 4 + +=item bit_names + +Returns a list of all the flags by name. + +=back + +=cut + +sub bits { + { + '-import' => { + # 'Template::Generic:generic' => '*', + }, + 'interface' => { + default => { + '*'=>'get_set', 'set_*'=>'set_true', 'clear_*'=>'set_false', + 'bit_fields'=>'bit_names', 'bit_string'=>'bit_string', + 'bit_list'=>'bit_list', 'bit_hash'=>'bit_hash', + }, + class_methods => { + 'bit_fields'=>'bit_names', 'bit_string'=>'bit_string', + 'bit_list'=>'bit_list', 'bit_hash'=>'bit_hash', + }, + }, + 'code_expr' => { + '_VEC_POS_VALUE_{}' => 'vec(_VALUE_, *, 1)', + _VEC_VALUE_ => '_VEC_POS_VALUE_{ _ATTR_{bfp} }', + _CLASS_INFO_ => '$Class::MakeMethods::Template::Hash::bits{_STATIC_ATTR_{target_class}}', + }, + 'modifier' => { + '-all' => [ q{ + defined _VALUE_ or _VALUE_ = ""; + * + } ], + }, + 'behavior' => { + '-init' => sub { + my $m_info = $_[0]; + + $m_info->{bfp} ||= do { + my $array = ( $Class::MakeMethods::Template::Hash::bits{$m_info->{target_class}} ||= [] ); + my $idx; + foreach ( 0..$#$array ) { + if ( $array->[$_] eq $m_info->{'name'} ) { $idx = $_; last } + } + unless ( $idx ) { + push @$array, $m_info->{'name'}; + $idx = $#$array; + } + $idx; + }; + + return; + }, + 'bit_names' => q{ + @{ _CLASS_INFO_ }; + }, + 'bit_string' => q{ + if ( @_ ) { + _SET_VALUE_{ shift @_ }; + } else { + _VALUE_; + } + }, + 'bits_size' => q{ + 8 * length( _VALUE_ ); + }, + 'bits_complement' => q{ + ~ _VALUE_; + }, + 'bit_hash' => q{ + my @bits = @{ _CLASS_INFO_ }; + if ( @_ ) { + my %bits = @_; + _SET_VALUE_{ pack 'b*', join '', map { $_ ? 1 : 0 } @bits{ @bits } }; + return @_; + } else { + map { $bits[$_], vec(_VALUE_, $_, 1) } 0 .. $#bits + } + }, + 'bit_list' => q{ + if ( @_ ) { + _SET_VALUE_{ pack 'b*', join( '', map { $_ ? 1 : 0 } @_ ) }; + return map { $_ ? 1 : 0 } @_; + } else { + split //, unpack "b*", _VALUE_; + } + }, + 'bit_pos_get' => q{ + vec(_VALUE_, $_[0], 1) + }, + 'bit_pos_set' => q{ + vec(_VALUE_, $_[0], 1) = ( $_[1] ? 1 : 0 ) + }, + + 'get_set' => q{ + if ( @_ ) { + _VEC_VALUE_ = ( $_[0] ? 1 : 0 ); + } else { + _VEC_VALUE_; + } + }, + 'get' => q{ + _VEC_VALUE_; + }, + 'set' => q{ + _VEC_VALUE_ = ( $_[0] ? 1 : 0 ); + }, + 'set_true' => q{ + _VEC_VALUE_ = 1; + }, + 'set_false' => q{ + _VEC_VALUE_ = 0; + }, + + }, + } +} + + +######################################################################## + +=head2 array Accessor + +Creates accessor methods for manipulating arrays of values. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides get_set behavior for I<*>, and I<verb>_I<*> methods for the non-get behaviors below. + +=item minimal + +Provides get_set behavior for I<*>, and I<*>_I<verb> methods for clear behavior. + +=item get_set_items + +Provides the get_set_items for I<*>. + +=item x_verb + +Provides get_push behavior for I<*>, and I<*>_I<verb> methods for the non-get behaviors below. + +=item get_set_ref + +Provides the get_set_ref for I<*>. + +=item get_set_ref_help + +Provides the get_set_ref for I<*>, and I<verb>_I<*> methods for the non-get behaviors below. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get_set_items + +Called with no arguments returns a reference to the array stored in the slot. + +Called with one simple scalar argument it treats the argument as an index +and returns the value stored under that index. + +Called with more than one argument, treats them as a series of index/value +pairs and adds them to the array. + +=item get_push + +If arguments are passed, these values are pushed on to the list; if a single array ref is passed, its values are used as the arguments. + +This method returns the list of values stored in the slot. In an array +context it returns them as an array and in a scalar context as a +reference to the array. + +=item get_set_ref + +If arguments are passed, these values are placed on the list, replacing the current contents; if a single array ref is passed, its values are used as the arguments. + +This method returns the list of values stored in the slot. In an array +context it returns them as an array and in a scalar context as a +reference to the array. + +=item get_set + +If arguments are passed, these values are placed on the list, replacing the current contents. + +This method returns the list of values stored in the slot. In an array +context it returns them as an array and in a scalar context as a +reference to the array. + + +=item push + +Append items to tail. + +=item pop + +Remove an item from the tail. + +=item shift + +Remove an item from the front. + +=item unshift + +Prepend items to front. + +=item splice + +Remove or replace items. + +=item clear + +Remove all items. + +=item count + +Returns the number of item in the list. + +=back + +=cut + +sub array { + { + '-import' => { 'Template::Generic:generic' => '*' }, + 'interface' => { + default => { + '*'=>'get_set', + map( ($_.'_*' => $_ ), qw( pop push unshift shift splice clear count )), + map( ('*_'.$_ => $_ ), qw( ref index ) ), + }, + minimal => { '*'=>'get_set', '*_clear'=>'clear' }, + get_set_items => { '*'=>'get_set_items' }, + x_verb => { + '*'=>'get_set', + map( ('*_'.$_ => $_ ), qw(pop push unshift shift splice clear count ref index )), + }, + get_set_ref => { '*'=>'get_set_ref' }, + get_set_ref_help => { '*'=>'get_set_ref', '-base'=>'default' }, + }, + 'modifier' => { + '-all' => [ q{ _ENSURE_REF_VALUE_; * } ], + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ _REF_VALUE_ ||= []; }, + }, + 'behavior' => { + 'get_set' => q{ + @{_REF_VALUE_} = @_ if ( scalar @_ ); + return wantarray ? @{_GET_VALUE_} : _REF_VALUE_; + }, + 'get_set_ref' => q{ + @{_REF_VALUE_} = ( ( scalar(@_) == 1 and ref($_[0]) eq 'ARRAY' ) ? @{$_[0]} : @_ ) if ( scalar @_ ); + return wantarray ? @{_GET_VALUE_} : _REF_VALUE_; + }, + 'get_push' => q{ + push @{_REF_VALUE_}, map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_; + return wantarray ? @{_GET_VALUE_} : _REF_VALUE_; + }, + 'ref' => q{ _REF_VALUE_ }, + 'get' => q{ return wantarray ? @{_GET_VALUE_} : _REF_VALUE_ }, + 'set' => q{ @{_REF_VALUE_} = @_ }, + 'pop' => q{ pop @{_REF_VALUE_} }, + 'push' => q{ push @{_REF_VALUE_}, @_ }, + 'shift' => q{ shift @{_REF_VALUE_} }, + 'unshift' => q{ unshift @{_REF_VALUE_}, @_ }, + 'slice' => q{ _GET_VALUE_->[ @_ ] }, + 'splice' => q{ splice @{_REF_VALUE_}, shift, shift, @_ }, + 'count' => q{ scalar @{_GET_VALUE_} }, + 'clear' => q{ @{ _REF_VALUE_ } = () }, + 'index' => q{ + my $list = _REF_VALUE_; + ( scalar(@_) == 1 ) ? $list->[shift] + : wantarray ? (map $list->[$_], @_) : [map $list->[$_], @_] + }, + 'get_set_items' => q{ + if ( scalar @_ == 0 ) { + return _REF_VALUE_; + } elsif ( scalar @_ == 1 ) { + return _GET_VALUE_->[ shift() ]; + } else { + _BEHAVIOR_{set_items} + } + }, + 'set_items' => q{ + ! (@_ % 2) or croak "Odd number of items in assigment to _STATIC_ATTR_{name}"; + while ( scalar @_ ) { + my ($index, $value) = splice @_, 0, 2; + _REF_VALUE_->[ $index ] = $value; + } + return _REF_VALUE_; + }, + } + } +} + +######################################################################## + +=head2 hash Accessor + +Creates accessor methods for manipulating hashes of key-value pairs. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides get_set behavior for I<*>, and I<*>_I<verb> methods for most of the other behaviors below. + +=item get_set_items + +Provides the get_set_items for I<*>. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get_set_items + +Called with no arguments returns a reference to the hash stored. + +Called with one simple scalar argument it treats the argument as a key +and returns the value stored under that key. + +Called with more than one argument, treats them as a series of key/value +pairs and adds them to the hash. + +=item get_push + +Called with no arguments returns the hash stored, as a hash +in a list context or as a reference in a scalar context. + +Called with one simple scalar argument it treats the argument as a key +and returns the value stored under that key. + +Called with one array reference argument, the array elements +are considered to be be keys of the hash. x returns the list of values +stored under those keys (also known as a I<hash slice>.) + +Called with one hash reference argument, the keys and values of the +hash are added to the hash. + +Called with more than one argument, treats them as a series of key/value +pairs and adds them to the hash. + +=item get_set + +Like get_push, except if called with more then one argument, empties +the current hash items before adding those arguments to the hash. + +=item push + +Called with one hash reference argument, the keys and values of the +hash are added to the hash. + +Called with more than one argument, treats them as a series of key/value +pairs and adds them to the hash. + +=item keys + +Returns a list of the keys of the hash. + +=item values + +Returns a list of the values in the hash. + +=item tally + +Takes a list of arguments and for each scalar in the list increments the +value stored in the hash and returns a list of the current (after the +increment) values. + +=item exists + +Takes a single key, returns whether that key exists in the hash. + +=item delete + +Takes a list, deletes each key from the hash, and returns the corresponding values. + +=item clear + +Resets hash to empty. + +=back + +=cut + +sub hash { + { + '-import' => { 'Template::Generic:generic' => '*' }, + 'interface' => { + 'default' => { + '*'=>'get_set', + map {'*_'.$_ => $_} qw(push set keys values delete exists tally clear), + }, + get_set_items => { '*'=>'get_set_items' }, + }, + 'modifier' => { + '-all' => [ q{ _ENSURE_REF_VALUE_; * } ], + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ _REF_VALUE_ ||= {}; }, + _HASH_GET_ => q{ + ( wantarray ? %{_GET_VALUE_} : _REF_VALUE_ ) + }, + _HASH_GET_VALUE_ => q{ + ( ref $_[0] eq 'ARRAY' ? @{ _GET_VALUE_ }{ @{ $_[0] } } + : _REF_VALUE_->{ $_[0] } ) + }, + _HASH_SET_ => q{ + ! (@_ % 2) or croak "Odd number of items in assigment to _STATIC_ATTR_{name}"; + %{_REF_VALUE_} = @_ + }, + _HASH_PUSH_ => q{ + ! (@_ % 2) + or croak "Odd number of items in assigment to _STATIC_ATTR_{name}"; + my $count; + while ( scalar @_ ) { + local $_ = shift; + _REF_VALUE_->{ $_ } = shift(); + ++ $count; + } + $count; + }, + }, + 'behavior' => { + 'get_set' => q { + # If called with no arguments, return hash contents + return _HASH_GET_ if (scalar @_ == 0); + + # If called with a hash ref, act as if contents of hash were passed + # local @_ = %{ $_[0] } if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ); + @_ = %{ $_[0] } if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ); + + # If called with an index, get that value, or a slice for array refs + return _HASH_GET_VALUE_ if (scalar @_ == 1 ); + + # Push on new values and return complete set + _HASH_SET_; + return _HASH_GET_; + }, + + 'get_push' => q{ + # If called with no arguments, return hash contents + return _HASH_GET_ if (scalar @_ == 0); + + # If called with a hash ref, act as if contents of hash were passed + # local @_ = %{ $_[0] } if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ); + @_ = %{ $_[0] } if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ); + + # If called with an index, get that value, or a slice for array refs + return _HASH_GET_VALUE_ if (scalar @_ == 1 ); + + # Push on new values and return complete set + _HASH_PUSH_; + return _HASH_GET_; + }, + 'get_set_items' => q{ + if ( scalar @_ == 0 ) { + return _REF_VALUE_; + } elsif ( scalar @_ == 1 ) { + return _REF_VALUE_->{ shift() }; + } else { + while ( scalar @_ ) { + my ($index, $value) = splice @_, 0, 2; + _REF_VALUE_->{ $index } = $value; + } + return _REF_VALUE_; + } + }, + 'get' => q{ _HASH_GET_ }, + 'set' => q{ _HASH_SET_ }, + 'push' => q{ + # If called with a hash ref, act as if contents of hash were passed + # local @_ = %{ $_[0] } if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ); + @_ = %{ $_[0] } if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ); + + _HASH_PUSH_ + }, + + 'keys' => q{ keys %{_GET_VALUE_} }, + 'values' => q{ values %{_GET_VALUE_} }, + 'unique_values' => q{ + values %{ { map { $_=>$_ } values %{_GET_VALUE_} } } + }, + 'delete' => q{ scalar @_ <= 1 ? delete @{ _REF_VALUE_ }{ $_[0] } + : map { delete @{ _REF_VALUE_ }{ $_ } } (@_) }, + 'exists' => q{ + return 0 unless defined _GET_VALUE_; + foreach (@_) { return 0 unless exists ( _REF_VALUE_->{$_} ) } + return 1; + }, + 'tally' => q{ map { ++ _REF_VALUE_->{$_} } @_ }, + 'clear' => q{ %{ _REF_VALUE_ } = () }, + 'ref' => q{ _REF_VALUE_ }, + }, + } +} + +######################################################################## + +=head2 tiedhash Accessor + +A variant of Generic:hash which initializes the hash by tieing it to a caller-specified package. + +See the documentation on C<Generic:hash> for interfaces and behaviors. + +B<Parameters>: The following parameters I<must> be provided: + +=over 4 + +=item tie + +I<Required>. The name of the class to tie to. +I<Make sure you have C<use>d the required class>. + +=item args + +I<Required>. Additional arguments for the tie, as an array ref. + +=back + +Example: + + use Class::MakeMethods + tie_hash => [ hits => { tie => q/Tie::RefHash/, args => [] } ]; + + use Class::MakeMethods + tie_hash => [ [qw(hits errors)] => { tie => q/Tie::RefHash/, args => [] } ]; + + use Class::MakeMethods + tie_hash => [ { name => hits, tie => q/Tie::RefHash/, args => [] } ]; + +=cut + +sub tiedhash { + { + '-import' => { 'Template::Generic:hash' => '*' }, + 'modifier' => { + '-all' => [ q{ + if ( ! defined _GET_VALUE_ ) { + %{ _REF_VALUE_ } = (); + tie %{ _REF_VALUE_ }, _ATTR_REQUIRED_{tie}, @{ _ATTR_{args} }; + } + * + } ], + }, + } +} + +######################################################################## + +=head2 hash_of_arrays Accessor + +Creates accessor methods for manipulating hashes of array-refs. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides get behavior for I<*>, and I<*>_I<verb> methods for the other behaviors below. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get + +Returns all the values for all the given keys, in order. If no keys are +given, returns all the values (in an unspecified key order). + +The result is returned as an arrayref in scalar context. This arrayref +is I<not> part of the data structure; messing with it will not affect +the contents directly (even if a single key was provided as argument.) + +If any argument is provided which is an arrayref, then the members of +that array are used as keys. Thus, the trivial empty-key case may be +utilized with an argument of []. + +=item keys + +Returns the keys of the hash. As an arrayref in scalar context. + +=item exists + +Takes a list of keys, and returns whether all of the key exists in the hash +(i.e., the C<and> of whether the individual keys exist). + +=item delete + +Takes a list, deletes each key from the hash. + +=item push + +Takes a key, and some values. Pushes the values onto the list denoted +by the key. If the first argument is an arrayref, then each element of +that arrayref is treated as a key and the elements pushed onto each +appropriate list. + +=item pop + +Takes a list of keys, and pops each one. Returns the list of popped +elements. undef is returned in the list for each key that is has an +empty list. + +=item unshift + +Like push, only the from the other end of the lists. + +=item shift + +Like pop, only the from the other end of the lists. + +=item splice + +Takes a key, offset, length, and a values list. Splices the list named +by the key. Anything from the offset argument (inclusive) may be +omitted. See L<perlfunc/splice>. + +=item clear + +Takes a list of keys. Resets each named list to empty (but does not +delete the keys.) + +=item count + +Takes a list of keys. Returns the sum of the number of elements for +each named list. + +=item index + +Takes a key, and a list of indices. Returns a list of each item at the +corresponding index in the list of the given key. Uses undef for +indices beyond range. + +=item remove + +Takes a key, and a list of indices. Removes each corresponding item +from the named list. The indices are effectively looked up at the point +of call -- thus removing indices 3, 1 from list (a, b, c, d) will +remove (d) and (b). + +=item sift + +Takes a key, and a set of named arguments, which may be a list or a hash +ref. Removes list members based on a grep-like approach. + +=over 4 + +=item filter + +The filter function used (as a coderef). Is passed two arguments, the +value compared against, and the value in the list that is potential for +grepping out. If returns true, the value is removed. Default is C<sub { $_[0] == $_[1] }>. + +=item keys + +The list keys to sift through (as an arrayref). Unknown keys are +ignored. Default: all the known keys. + +=item values + +The values to sift out (as an arrayref). Default: C<[undef]> + +=back + +=back + +=cut + +sub hash_of_arrays { + { + '-import' => { 'Template::Generic:hash' => '*' }, + 'interface' => { + default => { + '*'=>'get', + map( ('*_'.$_ => $_ ), qw(keys exists delete pop push shift unshift splice clear count index remove sift last set )), + }, + }, + 'behavior' => { + 'get' => q{ + my @Result; + + if ( ! scalar @_ ) { + @Result = map @$_, values %{_VALUE_}; + } elsif ( scalar @_ == 1 and ref ($_[0]) eq 'ARRAY' ) { + @Result = map @$_, @{_VALUE_}{@{$_[0]}}; + } else { + my @keys = map { ref ($_) eq 'ARRAY' ? @$_ : $_ } + grep exists _VALUE_{$_}, @_; + @Result = map @$_, @{_VALUE_}{@keys}; + } + + return wantarray ? @Result : \@Result; + }, + 'pop' => q{ + map { pop @{_VALUE_->{$_}} } @_ + }, + 'last' => q{ + map { _VALUE_->{$_}->[-1] } @_ + }, + 'push' => q{ + for ( ( ref ($_[0]) eq 'ARRAY' ? @{shift()} : shift() ) ) { + push @{_VALUE_->{$_}}, @_; + } + }, + 'shift' => q{ + map { shift @{_VALUE_->{$_}} } @_ + }, + 'unshift' => q{ + for ( ( ref ($_[0]) eq 'ARRAY' ? @{shift()} : shift() ) ) { + unshift @{_VALUE_->{$_}}, @_; + } + }, + 'splice' => q{ + my $key = shift; + splice @{ _VALUE_->{$key} }, shift, shift, @_; + }, + 'clear' => q{ + foreach (@_) { _VALUE_->{$_} = []; } + }, + 'count' => q{ + my $Result = 0; + foreach (@_) { + # Avoid autovivifying additional entries. + $Result += exists _VALUE_->{$_} ? scalar @{_VALUE_->{$_}} : 0; + } + return $Result; + }, + 'index' => q{ + my $key_r = shift; + + my @Result; + my $key; + foreach $key ( ( ref ($key_r) eq 'ARRAY' ? @$key_r : $key_r ) ) { + my $ary = _VALUE_->{$key}; + for (@_) { + push @Result, ( @{$ary} > $_ ) ? $ary->[$_] : undef; + } + } + return wantarray ? @Result : \@Result; + }, + 'set' => q{ + my $key_r = shift; + + croak "_ATTR_{name} expects a key and then index => value pairs.\n" + if @_ % 2; + while ( scalar @_ ) { + my $pos = shift; + _VALUE_->{$key_r}->[ $pos ] = shift(); + } + return; + }, + 'remove' => q{ + my $key_r = shift; + + my $key; + foreach $key ( ( ref ($key_r) eq 'ARRAY' ? @$key_r : $key_r ) ) { + my $ary = _VALUE_->{$key}; + foreach ( sort {$b<=>$a} grep $_ < @$ary, @_ ) { + splice (@$ary, $_, 1); + } + } + return; + }, + 'sift' => q{ + my %args = ( scalar @_ == 1 and ref $_[0] eq 'HASH' ) ? %{$_[0]} : @_; + my $hash = _VALUE_; + my $filter_sr = $args{'filter'} || sub { $_[0] == $_[1] }; + my $keys_ar = $args{'keys'} || [ keys %$hash ]; + my $values_ar = $args{'values'} || [undef]; + + # This is harder than it looks; reverse means we want to grep out only + # if *none* of the values matches. I guess an evaled block, or closure + # or somesuch is called for. + # my $reverse = $args{'reverse'} || 0; + + my ($key, $i, $value); + KEY: foreach $key (@$keys_ar) { + next KEY unless exists $hash->{$key}; + INDEX: for ($i = $#{$hash->{$key}}; $i >= 0; $i--) { + foreach $value (@$values_ar) { + if ( $filter_sr->($value, $hash->{$key}[$i]) ) { + splice @{$hash->{$key}}, $i, 1; + next INDEX; + } + } + } + } + return; + }, + }, + } +} + +######################################################################## + +=head2 object Accessor + +Creates accessor methods for manipulating references to objects. + +In addition to creating a method to get and set the object reference, +the meta-method can also define forwarded methods that automatically +pass calls onto the object stored in that slot; see the description of the 'delegate' parameter below. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides get_set behavior for I<*>, clear behavior for 'delete_*', +and forwarding methods for any values in the method's 'delegate' +or 'soft_delegate' parameters. + +=item get_and_set + +Provides named get method, set_I<x> and clear_I<x> methods. + +=item get_init_and_set + +Provides named get_init method, set_I<x> and clear_I<x> methods. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get_set + +The get_set method, if called with a reference to an object of the +given class as the first argument, stores it. + +If called with any other arguments, creates and stores a new object, passing the arguemnts to the new() method for the object. + +If called without arguments, returns the current value, which may be undefined if one has not been stored yet. + +=item get_set_init + +The get_set_init method, if called with a reference to an object of the +given class as the first argument, stores it. + +If the slot is not filled yet it creates an object by calling the given +new method of the given class. Any arguments passed to the get_set_init +method are passed on to new. + +In all cases the object now stored is returned. + +=item get_init + +If the instance is empty, creates and stores a new one. Returns the instance. + +=item get + +Returns the current value, which may be undefined if one has not been stored yet. + +=item set + +If called with a reference to an object of the given class as the first argument, stores it. + +If called with any other arguments, creates and stores a new object, passing the arguments to the new() method. + +If called without arguments, creates and stores a new object, without any arguments to the new() method. + +=item clear + +Removes the reference value. + +=item I<forwarding> + +If a 'delegate' or 'soft_delegate' parameter is provided, methods +with those names are created that are forwarded directly to the +object in the slot, as described below. + +=back + +B<Parameters>: The following parameters are supported: + +=over 4 + +=item class + +I<Required>. The type of object that will be stored. + +=item new_method + +The name of the method to call on the above class to create a new instance. Defaults to 'new'. + +=item delegate + +The methods to forward to the object. Can contain a method name, +a string of space-spearated method names, or an array of method +names. This type of method will croak if it is called when the +target object is not defined. + +=item soft_delegate + +The methods to forward to the object, if it is present. Can contain +a method name, a string of space-spearated method names, or an +array of method names. This type of method will return nothing if +it is called when the target object is not defined. + +=back + +=cut + +sub object { + { + '-import' => { + # 'Template::Generic:generic' => '*', + }, + 'interface' => { + default => { '*'=>'get_set', 'clear_*'=>'clear' }, + get_set_init => { '*'=>'get_set_init', 'clear_*'=>'clear' }, + get_and_set => {'*'=>'get', 'set_*'=>'set', 'clear_*'=>'clear' }, + get_init_and_set => { '*'=>'get_init','set_*'=>'set','clear_*'=>'clear' }, + init_and_get => { '*'=>'init_and_get', -params=>{ init_method=>'init_*' } }, + }, + 'params' => { + new_method => 'new' + }, + 'code_expr' => { + '_CALL_NEW_AND_STORE_' => q{ + my $new_method = _ATTR_REQUIRED_{new_method}; + my $class = _ATTR_REQUIRED_{'class'}; + _SET_VALUE_{ $class->$new_method(@_) }; + }, + }, + 'behavior' => { + '-import' => { + 'Template::Generic:scalar' => [ qw( get clear ) ], + }, + 'get_set' => q{ + if ( scalar @_ ) { + if (ref $_[0] and UNIVERSAL::isa($_[0], _ATTR_REQUIRED_{'class'})) { + _SET_VALUE_{ shift }; + } else { + _CALL_NEW_AND_STORE_ + } + } else { + _VALUE_; + } + }, + 'set' => q{ + if ( ! defined $_[0] ) { + _SET_VALUE_{ undef }; + } elsif (ref $_[0] and UNIVERSAL::isa($_[0], _ATTR_REQUIRED_{'class'})) { + _SET_VALUE_{ shift }; + } else { + _CALL_NEW_AND_STORE_ + } + }, + 'get_init' => q{ + if ( ! defined _VALUE_ ) { + _CALL_NEW_AND_STORE_ + } + _VALUE_; + }, + 'init_and_get' => q{ + if ( ! defined _VALUE_ ) { + my $init_method = _ATTR_REQUIRED_{'init_method'}; + _SET_VALUE_{ _SELF_->$init_method( @_ ) }; + } else { + _BEHAVIOR_{get} + } + }, + 'get_set_init' => q{ + if (ref $_[0] and UNIVERSAL::isa($_[0], _ATTR_REQUIRED_{'class'})) { + _SET_VALUE_{ shift }; + } elsif ( ! defined _VALUE_ ) { + _CALL_NEW_AND_STORE_ + } + _VALUE_; + }, + '-subs' => sub { + { + 'delegate' => sub { my($m_info, $name) = @_; sub { + my $m_name = $m_info->{'name'}; + my $obj = (shift)->$m_name() + or Carp::croak("Can't forward $name because $m_name is empty"); + $obj->$name(@_) + } }, + 'soft_delegate' => sub { my($m_info, $name) = @_; sub { + my $m_name = $m_info->{'name'}; + my $obj = (shift)->$m_name() or return; + $obj->$name(@_) + } }, + } + }, + }, + } +} + +######################################################################## + +=head2 instance Accessor + +Creates methods to handle an instance of the calling class. + +PROFILES + +=over 4 + +=item default + +Provides named get method, and I<verb>_I<x> set, new, and clear methods. + +=item -implicit_new + +Provides named get_init method, and I<verb>_I<x> set, and clear methods. + +=item -x_verb + +Provides named get method, and I<x>_I<verb> set, new, and clear methods. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get + +Returns the value of the instance parameter, which may be undefined if one has not been stored yet. + +=item get_init + +If the instance is empty, creates and stores a new one. Returns the instance. + +=item set + +Takes a single argument and sets the instance to that value. + +=item new + +Creates and stores a new instance. + +=item clear + +Sets the instance parameter to undef. + +=back + +B<Parameters>: The following parameters are supported: + +=over 4 + +=item instance + +Holds the instance reference. Defaults to undef + +=item new_method + +The name of the method to call when creating a new instance. Defaults to 'new'. + +=back + +=cut + +sub instance { + { + '-import' => { + 'Template::Generic:object' => '*', + }, + 'interface' => { + default => 'get_set', + }, + 'code_expr' => { + '_CALL_NEW_AND_STORE_' => q{ + my $new_method = _ATTR_REQUIRED_{new_method}; + _SET_VALUE_{ (_SELF_)->$new_method(@_) }; + }, + }, + } +} + +######################################################################## + +=head2 array_of_objects Accessor + +Creates accessor methods for manipulating references to arrays of object references. + +Operates like C<Generic:array>, but prior to adding any item to +the array, it first checks to see if it is an instance of the +designated class, and if not passes it as an argument to that +class's new method and stores the result instead. + +Forwarded methods return a list of the results returned +by C<map>ing the method over each object in the array. + +See the documentation on C<Generic:array> for interfaces and behaviors. + +B<Parameters>: The following parameters are supported: + +=over 4 + +=item class + +I<Required>. The type of object that will be stored. + +=item delegate + +The methods to forward to the object. Can contain a method name, a string of space-spearated method names, or an array of method names. + +=item new_method + +The name of the method to call on the above class to create a new instance. Defaults to 'new'. + +=back + +=cut + +sub array_of_objects { + { + '-import' => { + 'Template::Generic:array' => '*', + }, + 'params' => { + new_method => 'new', + }, + 'modifier' => { + '-all get_set' => q{ _BLESS_ARGS_ * }, + '-all get_push' => q{ _BLESS_ARGS_ * }, + '-all set' => q{ _BLESS_ARGS_ * }, + '-all push' => q{ _BLESS_ARGS_ * }, + '-all unshift' => q{ _BLESS_ARGS_ * }, + # The below two methods are kinda broken, because the new values + # don't get auto-blessed properly... + '-all splice' => q{ * }, + '-all set_items' => q{ * }, + }, + 'code_expr' => { + '_BLESS_ARGS_' => q{ + my $new_method = _ATTR_REQUIRED_{'new_method'}; + @_ = map { + (ref $_ and UNIVERSAL::isa($_, _ATTR_REQUIRED_{class})) ? $_ + : _ATTR_{'class'}->$new_method($_) + } @_; + }, + }, + 'behavior' => { + '-subs' => sub { + { + 'delegate' => sub { my($m_info, $name) = @_; sub { + my $m_name = $m_info->{'name'}; + map { $_->$name(@_) } (shift)->$m_name() + } }, + } + }, + }, + } +} + +######################################################################## + +=head2 code Accessor + +Creates accessor methods for manipulating references to subroutines. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides the call_set functionality. + +=item method + +Provides the call_method functionality. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item call_set + +If called with one argument which is a CODE reference, it installs that +code in the slot. Otherwise it runs the code stored in the slot with +whatever arguments (including none) were passed in. + +=item call_method + +Just like B<call_set>, except the code is called like a method, with $self +as its first argument. Basically, you are creating a method which can be +different for each object. + +=back + +=cut + +sub code { + { + '-import' => { + # 'Template::Generic:generic' => '*', + }, + 'interface' => { + default => 'call_set', + call_set => 'call_set', + method => 'call_method', + }, + 'behavior' => { + '-import' => { + 'Template::Generic:scalar' => [ qw( get_set get set clear ) ], + }, + 'call_set' => q{ + if ( scalar @_ == 1 and ref($_[0]) eq 'CODE') { + _SET_VALUE_{ shift }; # Set the subroutine reference + } else { + &{ _VALUE_ }( @_ ); # Run the subroutine on the given arguments + } + }, + 'call_method' => q{ + if ( scalar @_ == 1 and ref($_[0]) eq 'CODE') { + _SET_VALUE_{ shift }; # Set the subroutine reference + } else { + &{ _VALUE_ }( _SELF_, @_ ); # Run the subroutine on self and args + } + }, + }, + } +} + + +######################################################################## + +=head2 code_or_scalar Accessor + +Creates accessor methods for manipulating either strings or references to subroutines. + +You can store any scalar value; code refs are executed when you retrieve the value, while other scalars are returned as-is. + +B<Interfaces>: The following calling interfaces are available. + +=over 4 + +=item default + +Provides the call_set functionality. + +=item method + +Provides the call_method functionality. + +=item eiffel + +Provides the named get_method, and a helper set_* method. + +=back + +B<Behaviors>: The following types of accessor methods are available. + +=over 4 + +=item get_set_call + +If called with an argument, either a CODE reference or some other scalar, it installs that code in the slot. Otherwise, if the current value runs the code stored in the slot with +whatever arguments (including none) were passed in. + +=item get_set_method + +Just like B<call_set>, except the code is called like a method, with $self +as its first argument. Basically, you are creating a method which can be +different for each object. + +=back + +=cut + +sub code_or_scalar { + { + '-import' => { 'Template::Generic:scalar' => '*' }, + 'interface' => { + default => 'get_set_call', + get_set => 'get_set_call', + eiffel => { '*'=>'get_method', 'set_*'=>'set' }, + method => 'get_set_method', + }, + 'params' => { + }, + 'behavior' => { + 'get_call' => q{ + my $value = _GET_VALUE_; + ( ref($value) eq 'CODE' ) ? &$value( @_ ) : $value + }, + 'get_method' => q{ + my $value = _GET_VALUE_; + ( ref($value) eq 'CODE' ) ? &$value( _SELF_, @_ ) : $value + }, + 'get_set_call' => q{ + if ( scalar @_ == 1 ) { + _BEHAVIOR_{set} + } else { + _BEHAVIOR_{get_call} + } + }, + 'get_set_method' => q{ + if ( scalar @_ == 1 ) { + _BEHAVIOR_{set} + } else { + _BEHAVIOR_{get_call} + } + }, + }, + } +} + + +######################################################################## + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for information about this family of subclasses. + +=cut + +1; diff --git a/lib/Class/MakeMethods/Template/Global.pm b/lib/Class/MakeMethods/Template/Global.pm new file mode 100644 index 0000000..0e4c79e --- /dev/null +++ b/lib/Class/MakeMethods/Template/Global.pm @@ -0,0 +1,97 @@ +package Class::MakeMethods::Template::Global; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; + +=head1 NAME + +Class::MakeMethods::Template::Global - Method that are not instance-dependent + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Global ( + scalar => [ 'foo' ] + ); + + package main; + + MyObject->foo('bar') + print MyObject->foo(); + ... + print $my_instance->foo(); # same thing + +=head1 DESCRIPTION + +These meta-methods access values that are shared across all instances +of your object in your process. For example, a hash_scalar meta-method +will be able to store a different value for each hash instance you +call it on, but a static_scalar meta-method will return the same +value for any instance it's called on, and setting it from any +instance will change the value that all other instances see. + +B<Common Parameters>: The following parameters are defined for Static meta-methods. + +=over 4 + +=item data + +The shared value. + +=back + +=cut + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'code_expr' => { + _VALUE_ => '_ATTR_{data}', + }, + 'params' => { + 'data' => undef, + } + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic should be supported: + + scalar + string + number + boolean + bits (?) + array + hash + tiedhash (?) + hash_of_arrays (?) + object + instance + array_of_objects (?) + code + code_or_scalar (?) + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a ? above have not been tested sufficiently; please inform the author if they do not function as you would expect. + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for more about this family of subclasses. + +See L<Class::MakeMethods::Template::Generic> for information about the various accessor interfaces subclassed herein. + +=cut + +1; diff --git a/lib/Class/MakeMethods/Template/Hash.pm b/lib/Class/MakeMethods/Template/Hash.pm new file mode 100644 index 0000000..9163178 --- /dev/null +++ b/lib/Class/MakeMethods/Template/Hash.pm @@ -0,0 +1,229 @@ +package Class::MakeMethods::Template::Hash; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; + +sub generic { + { + 'params' => { + 'hash_key' => '*', + }, + 'code_expr' => { + _VALUE_ => '_SELF_->{_STATIC_ATTR_{hash_key}}', + '-import' => { 'Template::Generic:generic' => '*' }, + _EMPTY_NEW_INSTANCE_ => 'bless {}, _SELF_CLASS_', + _SET_VALUES_FROM_HASH_ => 'while ( scalar @_ ) { local $_ = shift(); $self->{ $_ } = shift() }' + }, + 'behavior' => { + 'hash_delete' => q{ delete _VALUE_ }, + 'hash_exists' => q{ exists _VALUE_ }, + }, + 'modifier' => { + # XXX the below doesn't work because modifiers can't have params, + # although interfaces can... Either add support for default params + # in modifiers, or else move this to another class. + # X Should there be a version which uses caller() instead of target_class? + 'class_keys' => { 'hash_key' => '"*{target_class}::*{name}"' }, + } + } +} + +######################################################################## + +=head1 NAME + +Class::MakeMethods::Template::Hash - Method interfaces for hash-based objects + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Hash ( + new => [ 'new' ], + scalar => [ 'foo', 'bar' ] + ); + + package main; + + my $obj = MyObject->new( foo => "Foozle", bar => "Bozzle" ); + print $obj->foo(); + $obj->bar("Bamboozle"); + +=head1 DESCRIPTION + +These meta-methods create and access values within blessed hash objects. + +B<Common Parameters>: The following parameters are defined for Hash meta-methods. + +=over 4 + +=item hash_key + +The hash key to use when retrieving values from each hash instance. Defaults to '*', the name of the meta-method. + +Changing this allows you to change an accessor method name to something other than the name of the hash key used to retrieve its value. + +Note that this parameter is not portable to the other implementations, such as Global or InsideOut. + +You can take advantage of parameter expansion to define methods whose hash key is composed of the defining package's name and the individual method name, such as C<$self-E<gt>{I<MyObject>-I<foo>}>: + + 'hash_key' => '*{target_class}-*{name}' + +=back + +B<Common Behaviors> + +=over 4 + +=item Behavior: delete + +Deletes the named key and associated value from the current hash instance. + +=back + +=head2 Standard Methods + +The following methods from Generic are all supported: + + new + scalar + string + string_index + number + boolean + bits (*) + array + hash + tiedhash + hash_of_arrays + object + instance + array_of_objects + code + code_or_scalar + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a * above are specifically defined in this package, whereas the others are formed automatically by the interaction of this package's generic settings with the code templates provided by the Generic superclass. + +=cut + +# This is the only one that needs to be specifically defined. +sub bits { + { + '-import' => { 'Template::Generic:bits' => '*' }, + 'params' => { + 'hash_key' => '*{target_class}__*{template_name}', + }, + } +} + +######################################################################## + +=head2 struct + + struct => [ qw / foo bar baz / ]; + +Creates methods for setting, checking and clearing values which +are stored by position in an array. All the slots created with this +meta-method are stored in a single array. + +The argument to struct should be a string or a reference to an +array of strings. For each string meta-method x, it defines two +methods: I<x> and I<clear_x>. x returns the value of the x-slot. +If called with an argument, it first sets the x-slot to the argument. +clear_x sets the slot to undef. + +Additionally, struct defines three class method: I<struct>, which returns +a list of all of the struct values, I<struct_fields>, which returns +a list of all the slots by name, and I<struct_dump>, which returns a hash of +the slot-name/slot-value pairs. + +=cut + +sub struct { + ( { + 'interface' => { + default => { + '*'=>'get_set', 'clear_*'=>'clear', + 'struct_fields'=>'struct_fields', + 'struct'=>'struct', 'struct_dump'=>'struct_dump' + }, + }, + 'params' => { + 'hash_key' => '*{target_class}__*{template_name}', + }, + 'behavior' => { + '-init' => sub { + my $m_info = $_[0]; + + $m_info->{class} ||= $m_info->{target_class}; + + my $class_info = + ($Class::MakeMethods::Template::Hash::struct{$m_info->{class}} ||= []); + if ( ! defined $m_info->{sfp} ) { + foreach ( 0..$#$class_info ) { + if ( $class_info->[$_] eq $m_info->{'name'} ) { + $m_info->{sfp} = $_; + last + } + } + if ( ! defined $m_info->{sfp} ) { + push @$class_info, $m_info->{'name'}; + $m_info->{sfp} = $#$class_info; + } + } + return; + }, + + 'struct_fields' => sub { my $m_info = $_[0]; sub { + my $class_info = + ( $Class::MakeMethods::Template::Hash::struct{$m_info->{class}} ||= [] ); + @$class_info; + }}, + 'struct' => sub { my $m_info = $_[0]; sub { + my $self = shift; + $self->{$m_info->{hash_key}} ||= []; + if ( @_ ) { @{$self->{$m_info->{hash_key}}} = @_ } + @{$self->{$m_info->{hash_key}}}; + }}, + 'struct_dump' => sub { my $m_info = $_[0]; sub { + my $self = shift; + my $class_info = + ( $Class::MakeMethods::Template::Hash::struct{$m_info->{class}} ||= [] ); + map { ($_, $self->$_()) } @$class_info; + }}, + + 'get_set' => sub { my $m_info = $_[0]; sub { + my $self = shift; + $self->{$m_info->{hash_key}} ||= []; + + if ( @_ ) { + $self->{$m_info->{hash_key}}->[ $m_info->{sfp} ] = shift; + } + $self->{$m_info->{hash_key}}->[ $m_info->{sfp} ]; + }}, + 'clear' => sub { my $m_info = $_[0]; sub { + my $self = shift; + $self->{$m_info->{hash_key}} ||= []; + $self->{$m_info->{hash_key}}->[ $m_info->{sfp} ] = undef; + }}, + }, + } ) +} + +######################################################################## + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for more about this family of subclasses. + +See L<Class::MakeMethods::Template::Generic> for information about the various accessor interfaces subclassed herein. + +=cut + +1; diff --git a/lib/Class/MakeMethods/Template/Inheritable.pm b/lib/Class/MakeMethods/Template/Inheritable.pm new file mode 100644 index 0000000..ac6e7c0 --- /dev/null +++ b/lib/Class/MakeMethods/Template/Inheritable.pm @@ -0,0 +1,154 @@ +=head1 NAME + +Class::MakeMethods::Template::Inheritable - Overridable data + +=head1 SYNOPSIS + + package MyClass; + + use Class::MakeMethods( 'Template::Inheritable:scalar' => 'foo' ); + # We now have an accessor method for an "inheritable" scalar value + + MyClass->foo( 'Foozle' ); # Set a class-wide value + print MyClass->foo(); # Retrieve class-wide value + + my $obj = MyClass->new(...); + print $obj->foo(); # All instances "inherit" that value... + + $obj->foo( 'Foible' ); # until you set a value for an instance. + print $obj->foo(); # This now finds object-specific value. + ... + + package MySubClass; + @ISA = 'MyClass'; + + print MySubClass->foo(); # Intially same as superclass, + MySubClass->foo('Foobar'); # but overridable per subclass, + print $subclass_obj->foo(); # and shared by its instances + $subclass_obj->foo('Fosil');# until you override them... + ... + +=head1 DESCRIPTION + +The MakeMethods subclass provides accessor methods that search an inheritance tree to find a value. This allows you to set a shared or default value for a given class, and optionally override it in a subclass. + +=cut + +######################################################################## + +package Class::MakeMethods::Template::Inheritable; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; +use Carp; + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'modifier' => { + '-all' => [ q{ + _INIT_VALUE_CLASS_ + * + } ], + }, + 'code_expr' => { + '_VALUE_CLASS_' => '$_value_class', + '_INIT_VALUE_CLASS_' => q{ + my _VALUE_CLASS_; + my @_INC_search = ( _SELF_, _SELF_CLASS_ ); + while ( scalar @_INC_search ) { + _VALUE_CLASS_ = shift @_INC_search; + last if ( exists _ATTR_{data}->{_VALUE_CLASS_} ); + no strict 'refs'; + unshift @_INC_search, @{"_VALUE_CLASS_\::ISA"} if ! ref _VALUE_CLASS_; + } + }, + '_VALUE_' => '_ATTR_{data}->{_VALUE_CLASS_}', + '_GET_VALUE_' => q{ _ATTR_{data}->{_VALUE_CLASS_} }, + '_SET_VALUE_{}' => q{ do { my $data = *; defined($data) ? ( _VALUE_CLASS_ = _SELF_ and _ATTR_{data}->{_SELF_} = $data ) : ( delete _ATTR_{data}->{_SELF_} and undef ) } }, + }, + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic should be supported: + + scalar + string + string_index (?) + number + boolean (?) + bits (?) + array (?) + hash (?) + tiedhash (?) + hash_of_arrays (?) + object (?) + instance (?) + array_of_objects (?) + code (?) + code_or_scalar (?) + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a * above are specifically defined in this package, whereas the others are formed automatically by the interaction of this package's generic settings with the code templates provided by the Generic superclass. + +The items marked with a ? above have not been tested sufficiently; please inform the author if they do not function as you would expect. + +=cut + +sub array { + { + '-import' => { + 'Template::Generic:array' => '*', + }, + 'modifier' => { + '-all' => q{ _INIT_VALUE_CLASS_; _ENSURE_REF_VALUE_; * }, + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ _VALUE_ ||= []; }, + '_REF_VALUE_' => '(\@{_ATTR_{data}->{_VALUE_CLASS_}})', + }, + } +} + +sub hash { + { + '-import' => { + 'Template::Generic:hash' => '*', + }, + 'modifier' => { + '-all' => q{ _INIT_VALUE_CLASS_; _ENSURE_REF_VALUE_; * }, + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ _VALUE_ ||= {}; }, + '_REF_VALUE_' => '(\%{_ATTR_{data}->{_VALUE_CLASS_}})', + }, + } +} + +######################################################################## + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for more about this family of subclasses. + +See L<Class::MakeMethods::Template::Generic> for information about the various accessor interfaces subclassed herein. + +If you just need scalar accessors, see L<Class::Data::Inheritable> for a very elegant and efficient implementation. + +=cut + +######################################################################## + +1; diff --git a/lib/Class/MakeMethods/Template/InsideOut.pm b/lib/Class/MakeMethods/Template/InsideOut.pm new file mode 100644 index 0000000..964856c --- /dev/null +++ b/lib/Class/MakeMethods/Template/InsideOut.pm @@ -0,0 +1,218 @@ +package Class::MakeMethods::Template::InsideOut; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; + +my %ClassInfo; +my %Data; + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'code_expr' => { + '_VALUE_' => '_ATTR_{data}->{_SELF_}', + }, + 'behavior' => { + -register => [ sub { + my $m_info = shift; + my $class_info = ( $ClassInfo{$m_info->{target_class}} ||= [] ); + return ( + 'DESTROY' => sub { + my $self = shift; + foreach ( @$class_info ) { delete $self->{data}->{$self} } + # $self->SUPER::DESTROY( @_ ) + }, + ); + } ], + } + } +} + +######################################################################## + +=head1 NAME + +Class::MakeMethods::Template::InsideOut - External data + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::InsideOut ( + scalar => [ 'foo', 'bar' ] + ); + sub new { ... } + + package main; + + my $obj = MyObject->new( foo => "Foozle", bar => "Bozzle" ); + print $obj->foo(); # Prints Foozle + $obj->bar("Bamboozle"); # Sets $obj's bar value + +=head1 DESCRIPTION + +Supports the Generic object constructor and accessors meta-method +types, but accepts any object as the underlying implementation type, +with member data stored in external indices. + +Each method stores the values associated with various objects in +an hash keyed by the object's stringified identity. Since that hash +is accessible only from the generated closures, it is impossible +for foreign code to manipulate those values except through the +method interface. + +A DESTROY method is installed to remove data for expired objects +from the various hashes. (If the DESTROY method is not called, your +program will not release this data and memory will be wasted.) + +B<Common Parameters>: The following parameters are defined for +InsideOut meta-methods. + +=over 4 + +=item data + +An auto-vivified reference to a hash to be used to store the values +for each object. + +=back + +Note that using InsideOut meta-methods causes the installation of +a DESTROY method in the calling class, which deallocates data for +each instance when it is discarded. + +NOTE: This needs some more work to properly handle inheritance. + +=head2 Standard Methods + +The following methods from Generic are all supported: + + scalar + string + string_index * + number + boolean + bits + array + hash + tiedhash + hash_of_arrays + object + instance + array_of_objects + code + code_or_scalar + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a * above are specifically defined in this package, whereas the others are formed automatically by the interaction of this package's generic settings with the code templates provided by the Generic superclass. + +=cut + +######################################################################## + +=head2 boolean_index + + boolean_index => [ qw / foo bar baz / ] + +Like InsideOut:boolean, boolean_index creates x, set_x, and clear_x +methods. However, it also defines a class method find_x which returns +a list of the objects which presently have the x-flag set to +true. + +Note that to free items from memory, you must clear these bits! + +=cut + +sub boolean_index { + { + '-import' => { + 'Template::Generic:boolean' => '*', + }, + 'interface' => { + default => { + '*'=>'get_set', 'set_*'=>'set_true', 'clear_*'=>'set_false', + 'find_*'=>'find_true', + }, + }, + 'behavior' => { + '-init' => [ sub { + my $m_info = $_[0]; + defined $m_info->{data} or $m_info->{data} = {}; + return; + } ], + 'set_true' => q{ _SET_VALUE_{ _SELF_ } }, + 'set_false' => q{ delete _VALUE_; 0 }, + 'find_true' => q{ + values %{ _ATTR_{data} }; + }, + }, + } +} + +sub string_index { + { + '-import' => { + 'Template::Generic:string_index' => '*', + }, + 'interface' => { + default => { + '*'=>'get_set', 'set_*'=>'set_true', 'clear_*'=>'set_false', + 'find_*'=>'find_true', + }, + }, + 'code_expr' => { + _INDEX_HASH_ => '_ATTR_{data}', + _GET_FROM_INDEX_ => q{ + if (defined ( my $old_v = _GET_VALUE_ ) ) { + delete _ATTR_{'data'}{ $old_v }; + } + }, + _REMOVE_FROM_INDEX_ => q{ + if (defined ( my $old_v = _GET_FROM_INDEX_ ) ) { + delete _ATTR_{'data'}{ $old_v }; + } + }, + _ADD_TO_INDEX_{} => q{ + if (defined ( my $new_value = _GET_VALUE_ ) ) { + if ( my $old_item = _ATTR_{'data'}{$new_value} ) { + # There's already an object stored under that value so we + # need to unset it's value. + # And maybe issue a warning? Or croak? + my $m_name = _ATTR_{'name'}; + $old_item->$m_name( undef ); + } + + # Put ourself in the index under that value + _ATTR_{'data'}{ * } = _SELF_; + } + }, + }, + 'behavior' => { + '-init' => [ sub { + my $m_info = $_[0]; + defined $m_info->{data} or $m_info->{data} = {}; + return; + } ], + 'get' => q{ + return _GET_FROM_INDEX_; + }, + 'set' => q{ + my $new_value = shift; + _REMOVE_FROM_INDEX_ + _ADD_TO_INDEX_{ $new_value } + }, + 'clear' => q{ + _REMOVE_FROM_INDEX_ + }, + }, + } +} + +######################################################################## + +1; diff --git a/lib/Class/MakeMethods/Template/PackageVar.pm b/lib/Class/MakeMethods/Template/PackageVar.pm new file mode 100644 index 0000000..da0f7be --- /dev/null +++ b/lib/Class/MakeMethods/Template/PackageVar.pm @@ -0,0 +1,168 @@ +package Class::MakeMethods::Template::PackageVar; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.0; +use Carp; + +=head1 NAME + +Class::MakeMethods::Template::PackageVar - Static methods with global variables + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::PackageVar ( + scalar => [ 'foo' ] + ); + + package main; + + MyObject->foo('bar') + print MyObject->foo(); + + $MyObject::foo = 'bazillion'; + print MyObject->foo(); + +=head1 DESCRIPTION + +These meta-methods provide access to package (class global) variables. +These are essentially the same as the Static meta-methods, except +that they use a global variable in the declaring package to store +their values. + +B<Common Parameters>: The following parameters are defined for PackageVar meta-methods. + +=over 4 + +=item variable + +The name of the variable to store the value in. Defaults to the same name as the method. + +=back + +=cut + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'params' => { + 'variable' => '*' + }, + 'modifier' => { + '-all' => [ q{ no strict; * } ], + }, + 'code_expr' => { + '_VALUE_' => '${_ATTR_{target_class}."::"._ATTR_{variable}}', + }, + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic should all be supported: + + scalar + string + string_index (?) + number + boolean + bits (?) + array (*) + hash (*) + tiedhash (?) + hash_of_arrays (?) + object (?) + instance (?) + array_of_objects (?) + code (?) + code_or_scalar (?) + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +The items marked with a * above are specifically defined in this package, whereas the others are formed automatically by the interaction of this package's generic settings with the code templates provided by the Generic superclass. + +The items marked with a ? above have not been tested sufficiently; please inform the author if they do not function as you would expect. + +=cut + +######################################################################## + +sub array { + { + '-import' => { + 'Template::Generic:array' => '*', + }, + 'modifier' => { + '-all' => q{ no strict; _ENSURE_REF_VALUE_; * }, + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ + _REF_VALUE_ or @{_ATTR_{target_class}."::"._ATTR_{variable}} = (); + }, + '_VALUE_' => '\@{_ATTR_{target_class}."::"._ATTR_{variable}}', + }, + } +} + +######################################################################## + +sub hash { + { + '-import' => { + 'Template::Generic:hash' => '*', + }, + 'modifier' => { + '-all' => q{ no strict; _ENSURE_REF_VALUE_; * }, + }, + 'code_expr' => { + '_ENSURE_REF_VALUE_' => q{ + _REF_VALUE_ or %{_ATTR_{target_class}."::"._ATTR_{variable}} = (); + }, + '_VALUE_' => '\%{_ATTR_{target_class}."::"._ATTR_{variable}}', + }, + } +} + +######################################################################## + +=head2 PackageVar:vars + +This rewrite rule converts package variable names into PackageVar methods of the equivalent data type. + +Here's an example declaration: + + package MyClass; + + use Class::MakeMethods::Template::PackageVar ( + vars => '$DEBUG %Index' + ); + +MyClass now has methods that get and set the contents of its $MyClass::DEBUG and %MyClass::Index package variables: + + MyClass->DEBUG( 1 ); + MyClass->Index( 'foo' => 'bar' ); + +=cut + +sub vars { + my $mm_class = shift; + my @rewrite = map [ "Template::PackageVar:$_" ], qw( scalar array hash ); + my %rewrite = ( '$' => 0, '@' => 1, '%' => 2 ); + while (@_) { + my $name = shift; + my $data = shift; + $data =~ s/\A(.)//; + push @{ $rewrite[ $rewrite{ $1 } ] }, { 'name'=>$name, 'variable'=>$data }; + } + return @rewrite; +} + + +1; diff --git a/lib/Class/MakeMethods/Template/Ref.pm b/lib/Class/MakeMethods/Template/Ref.pm new file mode 100644 index 0000000..d97bafa --- /dev/null +++ b/lib/Class/MakeMethods/Template/Ref.pm @@ -0,0 +1,207 @@ +=head1 NAME + +Class::MakeMethods::Template::Ref - Universal copy and compare methods + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Ref ( + 'Hash:new' => [ 'new' ], + clone => [ 'clone' ] + ); + + package main; + + my $obj = MyObject->new( foo => ["Foozle", "Bozzle"] ); + my $clone = $obj->clone(); + print $obj->{'foo'}[1]; + +=cut + +package Class::MakeMethods::Template::Ref; + +$VERSION = 1.008; +use strict; +require 5.00; +use Carp; + +use Class::MakeMethods::Template '-isasubclass'; +use Class::MakeMethods::Utility::Ref qw( ref_clone ref_compare ); + +###################################################################### + +=head1 DESCRIPTION + +The following types of methods are provided via the Class::MakeMethods interface: + +=head2 clone + +Produce a deep copy of an instance of almost any underlying datatype. + +Parameters: + +init_method + +If defined, this method is called on the new object with any arguments passed in. + +=cut + +sub clone { + { + 'params' => { 'init_method' => '' }, + 'interface' => { + default => 'clone', + clone => { '*'=>'clone', }, + }, + 'behavior' => { + 'clone' => sub { my $m_info = $_[0]; sub { + my $callee = shift; + ref $callee or croak "Can only copy instances, not a class.\n"; + + my $self = ref_clone( $callee ); + + my $init_method = $m_info->{'init_method'}; + if ( $init_method ) { + $self->$init_method( @_ ); + } elsif ( scalar @_ ) { + croak "No init_method"; + } + return $self; + }}, + }, + } +} + +###################################################################### + +=head2 prototype + +Create new instances by making a deep copy of a static prototypical instance. + +Parameters: + +init_method + +If defined, this method is called on the new object with any arguments passed in. +=cut + +sub prototype { + ( { + 'interface' => { + default => { '*'=>'set_or_new', }, + }, + 'behavior' => { + 'set_or_new' => sub { my $m_info = $_[0]; sub { + my $class = shift; + + if ( scalar @_ == 1 and UNIVERSAL::isa( $_[0], $class ) ) { + # set + $m_info->{'instance'} = shift + + } else { + # get + croak "Prototype is not defined" unless $m_info->{'instance'}; + my $self = ref_clone($m_info->{'instance'}); + + my $init_method = $m_info->{'init_method'}; + if ( $init_method ) { + $self->$init_method( @_ ); + } elsif ( scalar @_ ) { + croak "No init_method"; + } + return $self; + } + }}, + 'set' => sub { my $m_info = $_[0]; sub { + my $class = shift; + $m_info->{'instance'} = shift + }}, + 'new' => sub { my $m_info = $_[0]; sub { + my $class = shift; + + croak "Prototype is not defined" unless $m_info->{'instance'}; + my $self = ref_clone($m_info->{'instance'}); + + my $init_method = $m_info->{'init_method'}; + if ( $init_method ) { + $self->$init_method( @_ ); + } elsif ( scalar @_ ) { + croak "No init_method"; + } + return $self; + }}, + }, + } ) +} + +###################################################################### + +=head2 compare + +Compare one object to another. + +B<Templates> + +=over 4 + +=item * + +default + +Three-way (sorting-style) comparison. + +=item * + +equals + +Are these two objects equivalent? + +=item * + +identity + +Are these two references to the exact same object? + +=back + +=cut + +sub compare { + { + 'params' => { 'init_method' => '' }, + 'interface' => { + default => { '*'=>'compare', }, + equals => { '*'=>'equals', }, + identity => { '*'=>'identity', }, + }, + 'behavior' => { + 'compare' => sub { my $m_info = $_[0]; sub { + my $callee = shift; + ref_compare( $callee, shift ); + }}, + 'equals' => sub { my $m_info = $_[0]; sub { + my $callee = shift; + ref_compare( $callee, shift ) == 0; + }}, + 'identity' => sub { my $m_info = $_[0]; sub { + $_[0] eq $_[1] + }}, + }, + } +} + +###################################################################### + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for more about this family of subclasses. + +See L<Class::MakeMethods::Utility::Ref> for the clone and compare functions used above. + +=cut + +###################################################################### + +1; diff --git a/lib/Class/MakeMethods/Template/Scalar.pm b/lib/Class/MakeMethods/Template/Scalar.pm new file mode 100644 index 0000000..705f007 --- /dev/null +++ b/lib/Class/MakeMethods/Template/Scalar.pm @@ -0,0 +1,80 @@ +package Class::MakeMethods::Template::Scalar; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.00; +use Carp; + +=head1 NAME + +Class::MakeMethods::Template::Scalar - Methods for blessed scalars + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::ExternalData ( + new => 'new', + scalar => 'foo', + ); + + package main; + + my $obj = MyObject->new( foo => "Foozle" ); + print $obj->foo(); # Prints Foozle + $obj->foo("Bamboozle"); # Sets $$obj + print $obj->foo(); # Prints Bamboozle + +=head1 DESCRIPTION + +Supports the Generic object constructor and accessors meta-method +types, but uses scalar refs as the underlying implementation type, +so only one accessor method can be used effectively. + +=cut + +sub generic { + { + '-import' => { + 'Template::Generic:generic' => '*' + }, + 'code_expr' => { + _VALUE_ => '(${_SELF_})', + _EMPTY_NEW_INSTANCE_ => 'bless \( my $scalar = undef ), _SELF_CLASS_', + }, + 'params' => { + } + } +} + +######################################################################## + +=head2 Standard Methods + +The following methods from Generic are all supported: + + new + scalar + string + string_index + number + boolean + bits + array + hash + tiedhash + hash_of_arrays + object + instance + array_of_objects + code + code_or_scalar + +See L<Class::MakeMethods::Template::Generic> for the interfaces and behaviors of these method types. + +However, note that due to special nature of this package, all accessor methods reference the same scalar value, so setting a value with one method will overwrite the value retrieved by another. + +=cut + +1; diff --git a/lib/Class/MakeMethods/Template/Static.pm b/lib/Class/MakeMethods/Template/Static.pm new file mode 100644 index 0000000..4dfccca --- /dev/null +++ b/lib/Class/MakeMethods/Template/Static.pm @@ -0,0 +1,41 @@ +package Class::MakeMethods::Template::Static; + +use Class::MakeMethods::Template::Global '-isasubclass'; + +$VERSION = 1.008; + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Template::Static - Deprecated name for Global + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Global ( + scalar => [ 'foo' ] + ); + + package main; + + MyObject->foo('bar') + print MyObject->foo(); + ... + print $my_instance->foo(); # same thing + +=head1 DESCRIPTION + +Earlier versions of this package included a package named Class::MakeMethods::Template::Static. + +However, in hindsight, this name was poorly chosen, as it suggests a constant, unchanging value, whereas the actual functionality is akin to traditional "global" variables. + +This functionality is now provided by Class::MakeMethods::Template::Global, of which this is an empty subclass retained to provide backwards compatibility. + +=head1 SEE ALSO + +L<Class::MakeMethods::Template::Global>. + +=cut
\ No newline at end of file diff --git a/lib/Class/MakeMethods/Template/Struct.pm b/lib/Class/MakeMethods/Template/Struct.pm new file mode 100644 index 0000000..7d9540b --- /dev/null +++ b/lib/Class/MakeMethods/Template/Struct.pm @@ -0,0 +1,41 @@ +package Class::MakeMethods::Template::Struct; + +use Class::MakeMethods::Template::Array '-isasubclass'; + +$VERSION = 1.008; + +1; + +__END__ + +=head1 NAME + +Class::MakeMethods::Template::Struct - Deprecated name for Array + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Array ( + new => [ 'new' ] + scalar => [ 'foo', 'bar' ] + ); + + package main; + + my $obj = MyObject->new( foo => "Foozle", bar => "Bozzle" ); + print $obj->foo(); # Prints Foozle + $obj->bar("Bamboozle"); # Sets $obj->[1] + +=head1 DESCRIPTION + +Earlier versions of this package included a package named Class::MakeMethods::Template::Struct. + +However, in hindsight, this name was poorly chosen, as it suggests some connection to C-style structs, where the behavior implemented more simply parallels the functionality of Template::Hash and the other Generic subclasses. + +This functionality is now provided by Class::MakeMethods::Template::Array, of which this is an empty subclass retained to provide backwards compatibility. + +=head1 SEE ALSO + +L<Class::MakeMethods::Template::Array>. + +=cut
\ No newline at end of file diff --git a/lib/Class/MakeMethods/Template/StructBuiltin.pm b/lib/Class/MakeMethods/Template/StructBuiltin.pm new file mode 100644 index 0000000..b3ddc21 --- /dev/null +++ b/lib/Class/MakeMethods/Template/StructBuiltin.pm @@ -0,0 +1,148 @@ +package Class::MakeMethods::Template::StructBuiltin; + +use Class::MakeMethods::Template::Generic '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.00; +use Carp; + +=head1 NAME + +Class::MakeMethods::Template::StructBuiltin + +=head1 SYNOPSIS + + use Class::MakeMethods::Template::StructBuiltin ( + -TargetClass => 'MyStat', + builtin_isa => [ + '-{new_function}'=>'stat', + qw/ dev ino mode nlink / + ] + ); + + +=head1 DESCRIPTION + +This class generates a wrapper around some builtin function, +storing the results in the object and providing a by-name interface. + +Takes a (core) function name, and a arrayref of return position names +(we will call it pos_list). Creates: + +=over 4 + +=item new + +Calls the core func with any given arguments, stores the result in the +instance. + +=item x + +For each member of pos_list, creates a method of the same name which +gets/sets the nth member of the returned list, where n is the position +of x in pos_list. + +=item fields + +Returns pos_list, in the given order. + +=item dump + +Returns a list item name, item value, in order. + +=back + +Example Usage: + + package Stat; + + use Class::MakeMethods::Template::StructBuiltin + builtin_isa => [ '-{new_function}'=>'stat', qw/ dev ino mode nlink / ], + + package main; + + my $file = "$ENV{HOME}/.template"; + my $s = Stat->new($file); + print "File $file has ", $s->nlink, " links\n"; + +Note that (a) the new method does not check the return value of the +function called (in the above example, if $file does not exist, you will +silently get an empty object), and (b) if you really want the above +example, see the core File::stat module. But you get the idea, I hope. + +=cut + +sub builtin_isa { + ( { + 'template' => { + default => { + '*'=>'get_set', 'dump'=>'dump', 'fields'=>'fields', 'new'=>'new_builtin' + }, + }, + 'behavior' => { + '-init' => sub { + my $m_info = $_[0]; + + $m_info->{class} ||= $m_info->{target_class}; + + my $class_info = + ( $Class::MakeMethods::Struct::builtin{$m_info->{class}} ||= [] ); + if ( ! defined $m_info->{array_index} ) { + foreach ( 0..$#$class_info ) { + if ( $class_info->[$_] eq $m_info->{'name'} ) { + $m_info->{array_index} = $_; last } + } + if ( ! defined $m_info->{array_index} ) { + push @ $class_info, $m_info->{'name'}; + $m_info->{array_index} = $#$class_info; + } + } + + if (defined $m_info->{new_function} and ! ref $m_info->{new_function}) { + # NOTE Below comments found in original version of MethodMaker. -Simon + # Cuz neither \&{"CORE::$func"} or $CORE::{$func} work ... N.B. this + # only works for core functions that take only one arg. But I can't + # quite figure out how to pass in the list without it getting + # evaluated in a scalar context. Hmmm. + $m_info->{new_function} = eval "sub { + scalar \@_ ? CORE::$m_info->{new_function}(shift) + : CORE::$m_info->{new_function} + }"; + } + + return; + }, + + 'new_builtin' => sub { my $m_info = $_[0]; sub { + my $class = shift; + my $function = $m_info->{new_function}; + my $self = [ &$function(@_) ]; + bless $self, $class; + }}, + + 'fields' => sub { my $m_info = $_[0]; sub { + my $class_info = + ( $Class::MakeMethods::Struct::builtin{$m_info->{class}} ||= [] ); + @$class_info; + }}, + 'dump' => sub { my $m_info = $_[0]; sub { + my $self = shift; + my $class_info = + ( $Class::MakeMethods::Struct::builtin{$m_info->{class}} ||= [] ); + my @keys = @$class_info; + map ($keys[$_], $self->[$_]), 0 .. $#keys; + }}, + + 'get_set' => sub { my $m_info = $_[0]; sub { + my $self = shift; + if ( @_ ) { + $self->[ $m_info->{array_index} ] = shift; + } + $self->[ $m_info->{array_index} ]; + }}, + }, + } ) +} + +1; diff --git a/lib/Class/MakeMethods/Template/Universal.pm b/lib/Class/MakeMethods/Template/Universal.pm new file mode 100644 index 0000000..9535209 --- /dev/null +++ b/lib/Class/MakeMethods/Template/Universal.pm @@ -0,0 +1,415 @@ +package Class::MakeMethods::Template::Universal; + +use Class::MakeMethods::Template '-isasubclass'; + +$VERSION = 1.008; +use strict; +require 5.00; +require Carp; + +=head1 NAME + +Class::MakeMethods::Template::Universal - Meta-methods for any type of object + +=head1 SYNOPSIS + + package MyObject; + use Class::MakeMethods::Template::Universal ( + 'no_op' => [ 'twiddle' ], + 'croak' => [ 'fail', { croak_msg => 'Curses!' } ] + ); + + package main; + + MyObject->twiddle; # Does nothing + if ( $foiled ) { MyObject->fail() } # Dies with croak_msg + +=head1 DESCRIPTION + +=head1 UNIVERSAL META-METHODS + +The following meta-methods and behaviors are applicable across +multiple types of classes and objects. + +=head2 Universal:generic + +This is not a directly-invokable method type, but instead provides code expressions for use in other method-generators. + +You can use any of these features in your meta-method interfaces without explicitly importing them. + +B<Modifiers> + +=over 4 + +=item * + +--private + +Causes the method to croak if it is called from outside of the package which originally declared it. + +Note that this protection can currently be circumvented if your class provides the method_init behavior, or another subroutine that calls methods by name. + +=item * + +--protected + +Causes the method to croak if it is called from a package other than the declaring package and its inheritors. + +Note that this protection can currently be circumvented if your class provides the method_init behavior, or another subroutine that calls methods by name. + +=item * + +--public + +Cancels any previous -private or -protected declaration. + +=item * + +--self_closure + +Causes the method to return a function reference which is bound to the arguments provided when it is first called. + +For examples of usage, see the test scripts in t/*closure.t. + +=item * + +--lvalue + +Adds the ":lvalue" attribute to the subroutine declaration. + +For examples of usage, see the test scripts in t/*lvalue.t. + +=item * + +--warn_calls + +For diagnostic purposes, call warn with the object reference, method name, and arguments before executing the body of the method. + + +=back + + +B<Behaviors> + +=over 4 + +=item * + +attributes + +Runtime access to method parameters. + +=item * + +no_op -- See below. + +=item * + +croak -- See below. + +=item * + +method_init -- See below. + +=back + +=cut + +sub generic { + { + 'code_expr' => { + '_SELF_' => '$self', + '_SELF_CLASS_' => '(ref _SELF_ || _SELF_)', + '_SELF_INSTANCE_' => '(ref _SELF_ ? _SELF_ : undef)', + '_CLASS_FROM_INSTANCE_' => '(ref _SELF_ || croak "Can\'t invoke _STATIC_ATTR_{name} as a class method")', + '_ATTR_{}' => '$m_info->{*}', + '_STATIC_ATTR_{}' => '_ATTR_{*}', + '_ATTR_REQUIRED_{}' => + '(_ATTR_{*} or Carp::croak("No * parameter defined for _ATTR_{name}"))', + '_ATTR_DEFAULT_{}' => + sub { my @a = split(' ',$_[0],2); "(_ATTR_{$a[0]} || $a[1])" }, + + _ACCESS_PRIVATE_ => '( ( (caller)[0] eq _ATTR_{target_class} ) or croak "Attempted access to private method _ATTR_{name}")', + _ACCESS_PROTECTED_ => '( UNIVERSAL::isa((caller)[0], _ATTR_{target_class}) or croak "Attempted access to protected method _ATTR_{name}" )', + + '_CALL_METHODS_FROM_HASH_' => q{ + # Accept key-value attr list, or reference to unblessed hash of attrs + my @args = (scalar @_ == 1 and ref($_[0]) eq 'HASH') ? %{$_[0]} : @_; + while ( scalar @args ) { local $_ = shift(@args); $self->$_( shift(@args) ) } + }, + + }, + 'modifier' => { + 'self_closure' => q{ my @args = @_; return sub { unshift @_, @args; * } }, + 'warn_calls' => q{ warn $self."->_STATIC_ATTR_{name}(".join(', ',@_).")\n"; * }, + 'public' => q{ * }, + 'private' => q{ _ACCESS_PRIVATE_; * }, + 'protected' => q{ _ACCESS_PROTECTED_; * }, + '-folding' => [ + # Public is the default; all three options are mutually exclusive. + '-public' => '', + '-private -public' => '-public', + '-protected -public' => '-public', + '-private -protected' => '-protected', + '-protected -private' => '-private', + ], + 'lvalue' => { _SUB_ATTRIBS_ => ': lvalue' }, + }, + 'behavior' => { + -import => { + 'Template::Universal:no_op' => 'no_op', + 'Template::Universal:croak' => 'croak', + 'Template::Universal:method_init' => 'method_init', + }, + attributes => sub { + my $m_info = $_[0]; + return sub { + my $self = shift; + if ( scalar @_ == 0 ) { + return $m_info; + } elsif ( scalar @_ == 1 ) { + return $m_info->{ shift() }; + } else { + %$m_info = ( %$m_info, @_ ); + } + } + }, + }, + } +} + +######################################################################## + +=head2 no_op + +For each meta-method, creates a method with an empty body. + + use Class::MakeMethods::Template::Universal ( + 'no_op' => [ 'foo bar baz' ], + ); + +You might want to create and use such methods to provide hooks for +subclass activity. + +No interfaces or parameters supported. + +=cut + +sub no_op { + { + 'interface' => { + default => 'no_op', + 'no_op' => 'no_op' + }, + 'behavior' => { + no_op => sub { my $m_info = $_[0]; sub { } }, + }, + } +} + +######################################################################## + +=head2 croak + +For each meta-method, creates a method which will croak if called. + + use Class::MakeMethods::Template::Universal ( + 'croak' => [ 'foo bar baz' ], + ); + +This is intended to support the use of abstract methods, that must +be overidden in a useful subclass. + +If each subclass is expected to provide an implementation of a given method, using this abstract method will replace the generic error message below with the clearer, more explicit error message that follows it: + + Can't locate object method "foo" via package "My::Subclass" + The "foo" method is abstract and can not be called on My::Subclass + +However, note that the existence of this method will be detected by UNIVERSAL::can(), so it is not suitable for use in optional interfaces, for which you may wish to be able to detect whether the method is supported or not. + +The -unsupported and -prohibited interfaces provide alternate error +messages, or a custom error message can be provided using the +'croak_msg' parameter. + +=cut + +sub abstract { 'croak --abstract' } + +sub croak { + { + 'interface' => { + default => 'croak', + 'croak' => 'croak', + 'abstract' => { + '*'=>'croak', -params=> { 'croak_msg' => + q/Can't locate abstract method "*" declared in "*{target_class}", called from "CALLCLASS"./ + } + }, + 'abstract_minimal' => { + '*'=>'croak', -params=> { 'croak_msg' => + "The * method is abstract and can not be called" } + }, + 'unsupported' => { + '*'=>'croak', -params=> { 'croak_msg' => + "The * method does not support this operation" } + }, + 'prohibited' => { + '*'=>'croak', -params=> { 'croak_msg' => + "The * method is not allowed to perform this activity" } + }, + }, + 'behavior' => { + croak => sub { + my $m_info = $_[0]; + sub { + $m_info->{'croak_msg'} =~ s/CALLCLASS/ ref( $_[0] ) || $_[0] /ge + if $m_info->{'croak_msg'}; + Carp::croak( $m_info->{'croak_msg'} ); + } + }, + }, + } +} + +######################################################################## + +=head2 method_init + +Creates a method that accepts a hash of key-value pairs, or a +reference to hash of such pairs. For each pair, the key is interpreted +as the name of a method to call, and the value is the argument to +be passed to that method. + +Sample declaration and usage: + + package MyObject; + use Class::MakeMethods::Template::Universal ( + method_init => 'init', + ); + ... + + my $object = MyObject->new() + $object->init( foo => 'Foozle', bar => 'Barbados' ); + + # Equivalent to: + $object->foo('Foozle'); + $object->bar('Barbados'); + +You might want to create and use such methods to allow easy initialization of multiple object or class parameters in a single call. + +B<Note>: including methods of this type will circumvent the protection of C<private> and C<protected> methods, because it an outside caller can cause an object to call specific methods on itself, bypassing the privacy protection. + +=cut + +sub method_init { + { + 'interface' => { + default => 'method_init', + 'method_init' => 'method_init' + }, + 'code_expr' => { + '-import' => { 'Template::Universal:generic' => '*' }, + }, + 'behavior' => { + method_init => q{ + _CALL_METHODS_FROM_HASH_ + return $self; + } + }, + } +} + +######################################################################## + +=head2 forward_methods + +Creates a method which delegates to an object provided by another method. + +Example: + + use Class::MakeMethods::Template::Universal + forward_methods => [ + --target=> 'whistle', w, + [ 'x', 'y' ], { target=> 'xylophone' }, + { name=>'z', target=>'zither', target_args=>[123], method_name=>do_zed }, + ]; + +Example: The above defines that method C<w> will be handled by the +calling C<w> on the object returned by C<whistle>, whilst methods C<x> +and C<y> will be handled by C<xylophone>, and method C<z> will be handled +by calling C<do_zed> on the object returned by calling C<zither(123)>. + +B<Interfaces>: + +=over 4 + +=item forward (default) + +Calls the method on the target object. If the target object is missing, croaks at runtime with a message saying "Can't forward bar because bar is empty." + +=item delegate + +Calls the method on the target object, if present. If the target object is missing, returns nothing. + +=back + +B<Parameters>: The following additional parameters are supported: + +=over 4 + +=item target + +I<Required>. The name of the method that will provide the object that will handle the operation. + +=item target_args + +Optional ref to an array of arguments to be passed to the target method. + +=item method_name + +The name of the method to call on the handling object. Defaults to the name of the meta-method being created. + +=back + +=cut + +sub forward_methods { + { + 'interface' => { + default => 'forward', + 'forward' => 'forward' + }, + 'params' => { 'method_name' => '*' }, + 'behavior' => { + 'forward' => sub { my $m_info = $_[0]; sub { + my $target = $m_info->{'target'}; + my @args = $m_info->{'target_args'} ? @{$m_info->{'target_args'}} : (); + my $obj = (shift)->$target(@args) + or Carp::croak("Can't forward $m_info->{name} because $m_info->{target} is empty"); + my $method = $m_info->{'method_name'}; + $obj->$method(@_); + }}, + 'delegate' => sub { my $m_info = $_[0]; sub { + my $target = $m_info->{'target'}; + my @args = $m_info->{'target_args'} ? @{$m_info->{'target_args'}} : (); + my $obj = (shift)->$target(@args) + or return; + my $method = $m_info->{'method_name'}; + $obj->$method(@_); + }}, + }, + } +} + + +######################################################################## + +=head1 SEE ALSO + +See L<Class::MakeMethods> for general information about this distribution. + +See L<Class::MakeMethods::Template> for information about this family of subclasses. + +=cut + +1; |