package Class::MethodMaker::hash; use strict; use warnings; use AutoLoader 5.57 qw( AUTOLOAD ); our @ISA = qw( AutoLoader ); use Carp qw( carp croak cluck ); use constant DEBUG => $ENV{_CMM_DEBUG} ? 1 : 0; __END__ =head1 NAME Class::Method::hash - Create methods for handling a hash value. =head1 SYNOPSIS use Class::MethodMaker [ hash => [qw/ x /] ]; $instance->x; # empty $instance->x(a => 1, b => 2, c => 3); $instance->x_count == 3; # true $instance->x = (b => 5, d => 8); # Note this *replaces* the hash, # not adds to it $instance->x_index('b') == 5; # true $instance->x_exists('c'); # false $instance->x_exists('d'); # true =head1 DESCRIPTION Creates methods to handle hash values in an object. For a component named C, by default creates methods C, C, C, C, C, C, C, C, C, C, C, C, C. Methods available are: =head3 C<*> I. This method returns the list of keys and values stored in the slot (they are returned pairwise, i.e., key, value, key, value; as with perl hashes, no order of keys is guaranteed). If any arguments are provided to this method, they B the current hash contents. In an array context it returns the keys, values as an array and in a scalar context as a hash-reference. Note that this reference is no longer a direct reference to the storage, in contrast to Class::MethodMaker v1. This is to protect encapsulation. See x_ref if you need that functionality (and are prepared to take the associated risk.) If a single argument is provided that is an arrayref or hashref, it is expanded and its contents used in place of the existing contents. This is a more efficient passing mechanism for large numbers of values. =head3 C<*_reset> I. Called without an argument, this resets the component as a whole; deleting any associated storage, and returning the component to its default state. Normally, this means that I<*_isset> will return false, and I<*> will return undef. If C<-default> is in effect, then the component will be set to the default value, and I<*_isset> will return true. If C<-default_ctor> is in effect, then the default subr will be invoked, and its return value used to set the value of the component, and I<*_isset> will return true. If called with arguments, these arguments are treated as indexes into the component, and the individual elements thus referenced are reset (their storage deleted, so that I<*_isset(n)> will return false for appropriate I, except where C<-default> or C<-default_ctor> are in force, as above). As with perl arrays, resetting the highest set value implicitly decreases the count (but x_reset(n) never unsets the aggregate itself, even if all the elements are not set). =head3 C<*_clear> I. Empty the component of all elements, but without deleting the storage itself. If given a list of keys, then the elements I indexed by those keys are set to undef (but not deleted). Note the very different semantics: C<< $x->a_clear('b') >> sets the value of C in component 'a' to undef (if C) already exists (so C<< $x->a_isset('b')) >> returns true), but C<< $x->a_clear() >> deletes the element C from component 'a' (so C<< $x->a_isset('b')) >> returns false). =head3 C<*_isset> I. Whether the component is currently set. This is different from being defined; initially, the component is not set (and if read, will return undef); it can be set to undef (which is a set value, which also returns undef). Having been set, the only way to unset the component is with C<*_reset>. If a default value is in effect, then C<*_isset> will always return true. I<*_isset()> tests the component as a whole. I<*_isset(a)> tests the element indexed by I. I<*_isset(a,b)> tests the elements indexed by I, I, and returns the logical conjunction (I) of the tests. =head3 C<*_count> I. Returns the number of elements in this component. This is not affected by presence (or lack) of a C (or C). Returns C if whole component not set (as per I<*_isset>). =head3 C<*_index> I. Takes a list of indices, returns a list of the corresponding values. If a default (or a default ctor) is in force, then a lookup by index will vivify & set to the default the respective elements (and therefore the aggregate data-structure also, if it's not already). =head3 C<*_keys> I. The known keys, as a list in list context, as an arrayref in scalar context. If you're expecting a count of the keys in scalar context, see I<*_count>. =head3 C<*_values> I. The known values, as a list in list context, as an arrayref in scalar context. =head3 C<*_each> I. The next pair of key, value (as a list) from the hash. =head3 C<*_exists> I. Takes any number of arguments, considers each as a key, and determines whether the key exists in the has. Returns the logical conjunction (I). =head3 C<*_delete> I. This operates exactly like I<*_reset>, except that calling this with no args does nothing. This is provided for orthogonality with the Perl C operator, while I<*_reset> is provided for orthogonality with other component types. =head3 C<*_set> %n = $x->h; # (a=>1,b=>2,c=>3) (in some order) $h->h_set(b=>4,d=>7); %n = $h->a; # (a=>1,b=>4,c=>3,d=>7) (in some order) I. Takes a list, treated as pairs of index => value; each given index is set to the corresponding value. No return. If two arguments are given, of which the first is an arrayref, then it is treated as a list of indices of which the second argument (which must also be an arrayref) are the corresponding values. Thus the following two commands are equivalent: $x->a_set(b=>4,d=>7); $x->a_set(['b','d'],[4,7]); =head3 C<*_get> I. Retrieves the value of the component without setting (ignores any arguments passed). =cut #------------------ # hash sub hash0000 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default sub hash0004 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor sub hash0008 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb sub hash0040 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb sub hash0044 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb sub hash0048 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static sub hash0001 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static sub hash0005 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static sub hash0009 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static sub hash0041 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static sub hash0045 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static sub hash0049 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb sub hash0080 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb sub hash0084 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb sub hash0088 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb sub hash00c0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb sub hash00c4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb sub hash00c8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb sub hash0081 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb sub hash0085 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb sub hash0089 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb sub hash00c1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb sub hash00c5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb sub hash00c9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash tie_class sub hash0010 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - tie_class sub hash0014 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - tie_class sub hash0018 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - tie_class sub hash0050 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - tie_class sub hash0054 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - tie_class sub hash0058 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - tie_class sub hash0011 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - tie_class sub hash0015 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - tie_class sub hash0019 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - tie_class sub hash0051 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - tie_class sub hash0055 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - tie_class sub hash0059 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - tie_class sub hash0090 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - tie_class sub hash0094 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - tie_class sub hash0098 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - tie_class sub hash00d0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - tie_class sub hash00d4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - tie_class sub hash00d8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - tie_class sub hash0091 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - tie_class sub hash0095 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - tie_class sub hash0099 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - tie_class sub hash00d1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - tie_class sub hash00d5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - tie_class sub hash00d9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash type sub hash0002 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - type sub hash0006 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - type sub hash000a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - type sub hash0042 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - type sub hash0046 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - type sub hash004a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - type sub hash0003 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - type sub hash0007 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - type sub hash000b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - type sub hash0043 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - type sub hash0047 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - type sub hash004b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - type sub hash0082 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - type sub hash0086 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - type sub hash008a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - type sub hash00c2 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - type sub hash00c6 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - type sub hash00ca { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - type sub hash0083 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - type sub hash0087 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - type sub hash008b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - type sub hash00c3 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - type sub hash00c7 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - type sub hash00cb { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash tie_class - type sub hash0012 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - tie_class - type sub hash0016 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - tie_class - type sub hash001a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - tie_class - type sub hash0052 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - tie_class - type sub hash0056 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - tie_class - type sub hash005a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - tie_class - type sub hash0013 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - tie_class - type sub hash0017 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - tie_class - type sub hash001b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - tie_class - type sub hash0053 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - tie_class - type sub hash0057 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - tie_class - type sub hash005b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - tie_class - type sub hash0092 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - tie_class - type sub hash0096 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - tie_class - type sub hash009a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - tie_class - type sub hash00d2 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - tie_class - type sub hash00d6 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - tie_class - type sub hash00da { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - tie_class - type sub hash0093 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - tie_class - type sub hash0097 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - tie_class - type sub hash009b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - tie_class - type sub hash00d3 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - tie_class - type sub hash00d7 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - tie_class - type sub hash00db { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash typex sub hash0100 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - typex sub hash0104 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - typex sub hash0108 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - typex sub hash0140 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - typex sub hash0144 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - typex sub hash0148 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - typex sub hash0101 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - typex sub hash0105 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - typex sub hash0109 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - typex sub hash0141 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - typex sub hash0145 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - typex sub hash0149 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - typex sub hash0180 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - typex sub hash0184 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - typex sub hash0188 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - typex sub hash01c0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - typex sub hash01c4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - typex sub hash01c8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - typex sub hash0181 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - typex sub hash0185 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - typex sub hash0189 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - typex sub hash01c1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - typex sub hash01c5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - typex sub hash01c9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash tie_class - typex sub hash0110 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - tie_class - typex sub hash0114 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - tie_class - typex sub hash0118 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - tie_class - typex sub hash0150 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - tie_class - typex sub hash0154 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - tie_class - typex sub hash0158 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { +{%{$_[0]->{$name}} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { +{%{$_[0]->{$name}} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - tie_class - typex sub hash0111 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - tie_class - typex sub hash0115 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - tie_class - typex sub hash0119 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - tie_class - typex sub hash0151 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - tie_class - typex sub hash0155 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - tie_class - typex sub hash0159 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { +{%{$store[0]} = %{$_[1]}}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { +{%{$store[0]} = @_[1..$#_]}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - tie_class - typex sub hash0190 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - tie_class - typex sub hash0194 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - tie_class - typex sub hash0198 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - tie_class - typex sub hash01d0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - tie_class - typex sub hash01d4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - tie_class - typex sub hash01d8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { +{%{$_[0]->{$name}}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { +{%{$_[0]->{$name}} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - tie_class - typex sub hash0191 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - tie_class - typex sub hash0195 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - tie_class - typex sub hash0199 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - tie_class - typex sub hash01d1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - tie_class - typex sub hash01d5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - tie_class - typex sub hash01d9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { +{%{$store[0]}}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { +{%{$store[0]} = %$v}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old) for @store_callbacks; } else { $v = $_->($_[0], $v, $name) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash v1_compat sub hash0020 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - v1_compat sub hash0024 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - v1_compat sub hash0028 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - v1_compat sub hash0060 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - v1_compat sub hash0064 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - v1_compat sub hash0068 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - v1_compat sub hash0021 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - v1_compat sub hash0025 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - v1_compat sub hash0029 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - v1_compat sub hash0061 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - v1_compat sub hash0065 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - v1_compat sub hash0069 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - v1_compat sub hash00a0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - v1_compat sub hash00a4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - v1_compat sub hash00a8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - v1_compat sub hash00e0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - v1_compat sub hash00e4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - v1_compat sub hash00e8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - v1_compat sub hash00a1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - v1_compat sub hash00a5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - v1_compat sub hash00a9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - v1_compat sub hash00e1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - v1_compat sub hash00e5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - v1_compat sub hash00e9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash tie_class - v1_compat sub hash0030 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - tie_class - v1_compat sub hash0034 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - tie_class - v1_compat sub hash0038 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - tie_class - v1_compat sub hash0070 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - tie_class - v1_compat sub hash0074 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - tie_class - v1_compat sub hash0078 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - tie_class - v1_compat sub hash0031 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - tie_class - v1_compat sub hash0035 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - tie_class - v1_compat sub hash0039 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - tie_class - v1_compat sub hash0071 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - tie_class - v1_compat sub hash0075 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - tie_class - v1_compat sub hash0079 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - tie_class - v1_compat sub hash00b0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - tie_class - v1_compat sub hash00b4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - tie_class - v1_compat sub hash00b8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - tie_class - v1_compat sub hash00f0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - tie_class - v1_compat sub hash00f4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - tie_class - v1_compat sub hash00f8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - tie_class - v1_compat sub hash00b1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - tie_class - v1_compat sub hash00b5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - tie_class - v1_compat sub hash00b9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - tie_class - v1_compat sub hash00f1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - tie_class - v1_compat sub hash00f5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - tie_class - v1_compat sub hash00f9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash type - v1_compat sub hash0022 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - type - v1_compat sub hash0026 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - type - v1_compat sub hash002a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - type - v1_compat sub hash0062 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - type - v1_compat sub hash0066 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - type - v1_compat sub hash006a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - type - v1_compat sub hash0023 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - type - v1_compat sub hash0027 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - type - v1_compat sub hash002b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - type - v1_compat sub hash0063 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - type - v1_compat sub hash0067 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - type - v1_compat sub hash006b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - type - v1_compat sub hash00a2 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - type - v1_compat sub hash00a6 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - type - v1_compat sub hash00aa { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - type - v1_compat sub hash00e2 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - type - v1_compat sub hash00e6 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - type - v1_compat sub hash00ea { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - type - v1_compat sub hash00a3 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - type - v1_compat sub hash00a7 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - type - v1_compat sub hash00ab { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - type - v1_compat sub hash00e3 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - type - v1_compat sub hash00e7 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - type - v1_compat sub hash00eb { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash tie_class - type - v1_compat sub hash0032 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - tie_class - type - v1_compat sub hash0036 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - tie_class - type - v1_compat sub hash003a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - tie_class - type - v1_compat sub hash0072 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - tie_class - type - v1_compat sub hash0076 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - tie_class - type - v1_compat sub hash007a { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - tie_class - type - v1_compat sub hash0033 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - tie_class - type - v1_compat sub hash0037 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - tie_class - type - v1_compat sub hash003b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - tie_class - type - v1_compat sub hash0073 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - tie_class - type - v1_compat sub hash0077 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - tie_class - type - v1_compat sub hash007b { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - tie_class - type - v1_compat sub hash00b2 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - tie_class - type - v1_compat sub hash00b6 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - tie_class - type - v1_compat sub hash00ba { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - tie_class - type - v1_compat sub hash00f2 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - tie_class - type - v1_compat sub hash00f6 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - tie_class - type - v1_compat sub hash00fa { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - tie_class - type - v1_compat sub hash00b3 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - tie_class - type - v1_compat sub hash00b7 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - tie_class - type - v1_compat sub hash00bb { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - tie_class - type - v1_compat sub hash00f3 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - tie_class - type - v1_compat sub hash00f7 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - tie_class - type - v1_compat sub hash00fb { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { croak(sprintf("Incorrect type for attribute $name: %s\n" . " : should be '%s' (or subclass thereof)\n", (defined($_) ? (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : '*undef*' ), $type)) unless ! defined $_ or UNIVERSAL::isa($_, $type); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash typex - v1_compat sub hash0120 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - typex - v1_compat sub hash0124 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - typex - v1_compat sub hash0128 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - typex - v1_compat sub hash0160 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - typex - v1_compat sub hash0164 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - typex - v1_compat sub hash0168 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - typex - v1_compat sub hash0121 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - typex - v1_compat sub hash0125 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - typex - v1_compat sub hash0129 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - typex - v1_compat sub hash0161 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - typex - v1_compat sub hash0165 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - typex - v1_compat sub hash0169 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - typex - v1_compat sub hash01a0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - typex - v1_compat sub hash01a4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - typex - v1_compat sub hash01a8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - typex - v1_compat sub hash01e0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - typex - v1_compat sub hash01e4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - typex - v1_compat sub hash01e8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - typex - v1_compat sub hash01a1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - typex - v1_compat sub hash01a5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - typex - v1_compat sub hash01a9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - typex - v1_compat sub hash01e1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - typex - v1_compat sub hash01e5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - typex - v1_compat sub hash01e9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash tie_class - typex - v1_compat sub hash0130 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - tie_class - typex - v1_compat sub hash0134 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - tie_class - typex - v1_compat sub hash0138 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - tie_class - typex - v1_compat sub hash0170 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - tie_class - typex - v1_compat sub hash0174 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - tie_class - typex - v1_compat sub hash0178 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %{$_[1]}; return; } if ( $want ) { (%{$_[0]->{$name}} = %{$_[1]}); } else { %{$_[0]->{$name}} = %{$_[1]}; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = @_[1..$#_]; return; } if ( $want ) { (%{$_[0]->{$name}} = @_[1..$#_]); } else { %{$_[0]->{$name}} = @_[1..$#_]; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - tie_class - typex - v1_compat sub hash0131 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - tie_class - typex - v1_compat sub hash0135 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - tie_class - typex - v1_compat sub hash0139 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - tie_class - typex - v1_compat sub hash0171 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - tie_class - typex - v1_compat sub hash0175 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - tie_class - typex - v1_compat sub hash0179 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { # Only asgn-check the potential *values* for ( values %{$_[1]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %{$_[1]}; return; } if ( $want ) { (%{$store[0]} = %{$_[1]}); } else { %{$store[0]} = %{$_[1]}; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; # Only asgn-check the potential *values* for ( @_[map $_*2,1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = @_[1..$#_]; return; } if ( $want ) { (%{$store[0]} = @_[1..$#_]); } else { %{$store[0]} = @_[1..$#_]; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { for (@{$_[2]}) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @{$_[2]}; } else { for (@_[map {$_*2} 1..($#_/2)]) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $_[$_*2] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash store_cb - tie_class - typex - v1_compat sub hash01b0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - store_cb - tie_class - typex - v1_compat sub hash01b4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - store_cb - tie_class - typex - v1_compat sub hash01b8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - store_cb - tie_class - typex - v1_compat sub hash01f0 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - store_cb - tie_class - typex - v1_compat sub hash01f4 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - store_cb - tie_class - typex - v1_compat sub hash01f8 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $_[0]->{$name} ) { return unless defined $want; if ( $want ) { %{$_[0]->{$name}}; } else { $_[0]->{$name}; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; if ( ! defined $want ) { %{$_[0]->{$name}} = %$v; return; } if ( $want ) { (%{$_[0]->{$name}} = %$v); } else { %{$_[0]->{$name}} = %$v; $_[0]->{$name}; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $_[0]->{$name} = +{} unless exists $_[0]->{$name}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$_[0]->{$name}} : $_[0]->{$name}; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$_[0]->{$name}}; delete $_[0]->{$name}; } else { delete @{$_[0]->{$name}}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$_[0]->{$name}} = (); } else { ${$_[0]->{$name}}{$_} = undef for grep exists ${$_[0]->{$name}}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $_[0]->{$name} } elsif ( @_ == 2 ) { exists $_[0]->{$name}->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $_[0]->{$name}->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $_[0]->{$name} ) { return scalar keys %{$_[0]->{$name}}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists ($_[0]->{$name}->{$_}); if ( ! exists ($_[0]->{$name}->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ($_[0]->{$name}->{$_}) = $default } } @{$_[0]->{$name}}{@_[1..$#_]}; } : sub : method { @{$_[0]->{$name}}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$_[0]->{$name}}] : keys %{$_[0]->{$name}}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$_[0]->{$name}}] : values %{$_[0]->{$name}}; }, '*_each' => sub : method { return each %{$_[0]->{$name}}; }, '*_exists' => sub : method { return for grep ! exists $_[0]->{$name}->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; @{$_[0]->{$name}}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $_[0]->{$name} ) { my $old = $_[0]->{$name}; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$_[0]->{$name}}, $tie_class, @tie_args unless exists $_[0]->{$name}; ${$_[0]->{$name}}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $_[0]->{$name} }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash static - store_cb - tie_class - typex - v1_compat sub hash01b1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - static - store_cb - tie_class - typex - v1_compat sub hash01b5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - static - store_cb - tie_class - typex - v1_compat sub hash01b9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash read_cb - static - store_cb - tie_class - typex - v1_compat sub hash01f1 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default - read_cb - static - store_cb - tie_class - typex - v1_compat sub hash01f5 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------ # hash default_ctor - read_cb - static - store_cb - tie_class - typex - v1_compat sub hash01f9 { my $class = shift; my ($target_class, $name, $options, $global) = @_; my %known_options = map {; $_ => 1 } qw( static type forward default default_ctor tie_class tie_args read_cb store_cb v1_compat ); if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) { my $prefix = 'Option' . (@bad_opt > 1 ? 's' : ''); croak("$prefix not recognized for attribute type hash: ", join(', ', @bad_opt), "\n"); } my $type = $options->{type}; croak "argument to -type ($type) must be a simple value\n" unless ! ref $type; my $forward = $options->{forward}; my @forward; if ( defined $forward ) { if ( ref $forward ) { croak("-forward option can only handle arrayrefs or simple values " . "($forward)\n") unless UNIVERSAL::isa($forward, 'ARRAY'); @forward = @$forward; print "Value '$_' passed to -forward is not a simple value" for grep ref($_), @forward; } else { @forward = $forward; } } my ($default, $dctor, $default_defined); if ( exists $options->{default} ) { croak("Cannot specify both default & default_ctor options to hash ", "(attribute $name\n") if exists $options->{default_ctor}; $default = $options->{default}; $default_defined = 1; } elsif ( exists $options->{default_ctor} ) { if ( ! ref $options->{default_ctor} ) { my $meth = $options->{default_ctor}; croak("default_ctor can only be a simple value when -type is in effect", " (attribute $name)\n") unless defined $type; croak("default_ctor must be a valid identifier (or a code ref): $meth ", "(attribute $name)\n") unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/; $dctor = sub { $type->$meth(@_) }; } else { $dctor = $options->{default_ctor}; croak("Argument to default_ctor must be a simple value or a code ref ", " (attribute $name)\n") if ! UNIVERSAL::isa($dctor, 'CODE'); } $default_defined = 1; } my ($tie_class, @tie_args); if ( exists $options->{tie_class} ) { $tie_class = $options->{tie_class}; if ( exists $options->{tie_args} ) { my $tie_args = $options->{tie_args}; @tie_args = ref $tie_args ? @$tie_args : $tie_args; } } elsif ( exists $options->{tie_args} ) { carp "tie_args option ignored in absence of tie_class(attribute $name)\n"; } # callback options my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ? @{$options->{read_cb}} : $options->{read_cb} if exists $options->{read_cb}; my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ? @{$options->{store_cb}} : $options->{store_cb} if exists $options->{store_cb}; my @store; # Predefine keys for subs we always want to exist (because they're # referenced by other subs) my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each ); # The newer '*' treats a single +{} differently. This is needed to ensure # that hash_init works for v1 scenarios $names{'='} = '*_v1compat' if $options->{v1_compat}; return { '*' => sub : method { my $z = \@_; # work around stack problems my $want = wantarray; print STDERR "W: ", $want, ':', join(',',@_),"\n" if DEBUG; # We also deliberately avoid instantiating storage if not # necessary. if ( @_ == 1 ) { if ( exists $store[0] ) { return unless defined $want; if ( $want ) { %{$store[0]}; } else { $store[0]; } } else { return unless defined $want; if ( $want ) { (); } else { +{}; } } } elsif ( @_ == 2 and ref $_[1] eq 'HASH') { my $v = +{%{$_[1]}}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } else { croak "Uneven number of arguments to method '$names{'*'}'\n" unless @_ % 2; my $v = +{@_[1..$#_]}; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } # Only asgn-check the potential *values* for (values %$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; if ( ! defined $want ) { %{$store[0]} = %$v; return; } if ( $want ) { (%{$store[0]} = %$v); } else { %{$store[0]} = %$v; $store[0]; } } }, # # This method is for internal use only. It exists only for v1 # compatibility, and may change or go away at any time. Caveat # Emptor. # '!*_v1compat' => sub : method { my $want = wantarray; if ( @_ == 1 ) { # No args return unless defined $want; $store[0] = +{} unless exists $store[0]; return $want ? %{$store[0]} : $store[0]; } elsif ( @_ == 2 ) { # 1 arg if ( my $type = ref $_[1] ) { if ( $type eq 'ARRAY' ) { my $x = $names{'*_index'}; return my @x = $_[0]->$x(@{$_[1]}); } elsif ( $type eq 'HASH' ) { my $x = $names{'*_set'}; $_[0]->$x(%{$_[1]}); return $want ? %{$store[0]} : $store[0]; } else { # Not a recognized ref type for hash method # Assume it's an object type, for use with some tied hash $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # $key is simple scalar $x = $names{'*_index'}; return ($_[0]->$x($_[1]))[0]; } } else { # Many args unless ( @_ % 2 ) { carp "No value for key '$_[-1]'."; push @_, undef; } my $x = $names{'*_set'}; $_[0]->$x(@_[1..$#_]); $x = $names{'*'}; return $want ? %{$store[0]} : $store[0]; } }, '*_reset' => sub : method { if ( @_ == 1 ) { untie %{$store[0]}; delete $store[0]; } else { delete @{$store[0]}{@_[1..$#_]}; } return; }, '*_clear' => sub : method { if ( @_ == 1 ) { %{$store[0]} = (); } else { ${$store[0]}{$_} = undef for grep exists ${$store[0]}{$_}, @_[1..$#_]; } return; }, '*_isset' => ( $default_defined ? sub : method { 1 } : sub : method { if ( @_ == 1 ) { exists $store[0] } elsif ( @_ == 2 ) { exists $store[0]->{$_[1]} } else { for ( @_[1..$#_] ) { return if ! exists $store[0]->{$_}; } return 1; } } ), '*_count' => sub : method { if ( exists $store[0] ) { return scalar keys %{$store[0]}; } else { return; } }, # I did try to do clever things with returning refs if given refs, # but that conflicts with the use of lvalues '*_index' => ( $default_defined ? sub : method { for (@_[1..$#_]) { tie %{$store[0]}, $tie_class, @tie_args unless exists ($store[0]->{$_}); if ( ! exists ($store[0]->{$_}) ) { my $default = $dctor->($_[0]); for ($default) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ($store[0]->{$_}) = $default } } @{$store[0]}{@_[1..$#_]}; } : sub : method { @{$store[0]}{@_[1..$#_]}; } ), '*_keys' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [keys %{$store[0]}] : keys %{$store[0]}; }, '*_values' => sub : method { # Unusual ! wantarray order required because ?: supplies a scalar # context to it's middle argument. return ! wantarray ? [values %{$store[0]}] : values %{$store[0]}; }, '*_each' => sub : method { return each %{$store[0]}; }, '*_exists' => sub : method { return for grep ! exists $store[0]->{$_}, @_[1..$#_]; return 1; }, '*_delete' => sub : method { if ( @_ > 1 ) { my $x = $names{'*_reset'}; $_[0]->$x(@_[1..$#_]); } return; }, '*_set' => sub : method { croak sprintf("'%s' requires an even number of args (got %d)\n", $names{'*_set'}, @_-1) unless @_ % 2; if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) { my $v = [@{$_[2]}]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; @{$store[0]}{@{$_[1]}} = @$v; } else { my $v = [@_[map {$_*2} 1..($#_/2)]]; if ( exists $store[0] ) { my $old = $store[0]; $v = $_->($_[0], $v, $name, $old, ) for @store_callbacks; } else { $v = $_->($_[0], $v, $name, undef, ) for @store_callbacks; } for (@$v) { # $_ += 0; # croak(sprintf("Incorrect type for attribute $name: %s\n" . # " : should be '%s' (or subclass thereof)\n", # (defined($_) ? # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) : # '*undef*' # ), $typex)) # unless ! defined $_ or UNIVERSAL::isa($_, $typex); } tie %{$store[0]}, $tie_class, @tie_args unless exists $store[0]; ${$store[0]}{$_[$_*2-1]} = $v->[$_-1] for 1..($#_/2); } return; }, '*_get' => sub : method { my $x = $names{'*'}; return $_[0]->$x(); }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_tally' => sub : method { my @v; my ($y, $z) = @names{qw(*_set *_index)}; for (@_[1..$#_]) { my $v = $_[0]->$z($_); $v++; $_[0]->$y($_, $v); push @v, $v; } return @v; }, # # This method is deprecated. It exists only for v1 compatibility, # and may change or go away at any time. Caveat Emptor. # '!*_ref' => sub : method { $store[0] }, map({; my $f = $_; $_ => sub : method { my $x = $names{'*'}; my %y = $_[0]->$x(); while ( my($k, $v) = each %y ) { $y{$k} = $v->$f(@_[1..$#_]) if defined $v; } # Unusual ! wantarray order required because ?: supplies # a scalar context to it's middle argument. ! wantarray ? \%y : %y; } } @forward), }, \%names; } #------------------------------------ 1; # keep require happy