diff options
| author | Andreas Brachold <vdr07@deltab.de> | 2007-11-10 17:53:53 +0000 |
|---|---|---|
| committer | Andreas Brachold <vdr07@deltab.de> | 2007-11-10 17:53:53 +0000 |
| commit | cfdd733c17cfa4f1a43b827a656e9e53cc2524ac (patch) | |
| tree | b6f659b1281f77628b36768f0888f67b65f9ca48 /lib/Class/MakeMethods/Template | |
| parent | 9c6c30350161efd74faa3c3705096aecb71c0e81 (diff) | |
| download | xxv-cfdd733c17cfa4f1a43b827a656e9e53cc2524ac.tar.gz xxv-cfdd733c17cfa4f1a43b827a656e9e53cc2524ac.tar.bz2 | |
* Remove unsed packages
* Reorder exit routines
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, 0 insertions, 5047 deletions
diff --git a/lib/Class/MakeMethods/Template/Array.pm b/lib/Class/MakeMethods/Template/Array.pm deleted file mode 100644 index 0d2ab2d..0000000 --- a/lib/Class/MakeMethods/Template/Array.pm +++ /dev/null @@ -1,102 +0,0 @@ -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 deleted file mode 100644 index c846709..0000000 --- a/lib/Class/MakeMethods/Template/Class.pm +++ /dev/null @@ -1,103 +0,0 @@ -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 deleted file mode 100644 index 9c61393..0000000 --- a/lib/Class/MakeMethods/Template/ClassInherit.pm +++ /dev/null @@ -1,144 +0,0 @@ -=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 deleted file mode 100644 index c37433f..0000000 --- a/lib/Class/MakeMethods/Template/ClassName.pm +++ /dev/null @@ -1,330 +0,0 @@ -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 deleted file mode 100644 index a5a2478..0000000 --- a/lib/Class/MakeMethods/Template/ClassVar.pm +++ /dev/null @@ -1,178 +0,0 @@ -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 deleted file mode 100644 index 33f44ed..0000000 --- a/lib/Class/MakeMethods/Template/Flyweight.pm +++ /dev/null @@ -1,43 +0,0 @@ -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 deleted file mode 100644 index 368f21f..0000000 --- a/lib/Class/MakeMethods/Template/Generic.pm +++ /dev/null @@ -1,2349 +0,0 @@ -=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 deleted file mode 100644 index 0e4c79e..0000000 --- a/lib/Class/MakeMethods/Template/Global.pm +++ /dev/null @@ -1,97 +0,0 @@ -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 deleted file mode 100644 index 9163178..0000000 --- a/lib/Class/MakeMethods/Template/Hash.pm +++ /dev/null @@ -1,229 +0,0 @@ -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 deleted file mode 100644 index ac6e7c0..0000000 --- a/lib/Class/MakeMethods/Template/Inheritable.pm +++ /dev/null @@ -1,154 +0,0 @@ -=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 deleted file mode 100644 index 964856c..0000000 --- a/lib/Class/MakeMethods/Template/InsideOut.pm +++ /dev/null @@ -1,218 +0,0 @@ -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 deleted file mode 100644 index da0f7be..0000000 --- a/lib/Class/MakeMethods/Template/PackageVar.pm +++ /dev/null @@ -1,168 +0,0 @@ -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 deleted file mode 100644 index d97bafa..0000000 --- a/lib/Class/MakeMethods/Template/Ref.pm +++ /dev/null @@ -1,207 +0,0 @@ -=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 deleted file mode 100644 index 705f007..0000000 --- a/lib/Class/MakeMethods/Template/Scalar.pm +++ /dev/null @@ -1,80 +0,0 @@ -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 deleted file mode 100644 index 4dfccca..0000000 --- a/lib/Class/MakeMethods/Template/Static.pm +++ /dev/null @@ -1,41 +0,0 @@ -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 deleted file mode 100644 index 7d9540b..0000000 --- a/lib/Class/MakeMethods/Template/Struct.pm +++ /dev/null @@ -1,41 +0,0 @@ -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 deleted file mode 100644 index b3ddc21..0000000 --- a/lib/Class/MakeMethods/Template/StructBuiltin.pm +++ /dev/null @@ -1,148 +0,0 @@ -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 deleted file mode 100644 index 9535209..0000000 --- a/lib/Class/MakeMethods/Template/Universal.pm +++ /dev/null @@ -1,415 +0,0 @@ -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; |
