shell bypass 403
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<x>, by default creates methods C<x>, C<x_reset>, C<x_clear>, C<x_isset>,
C<x_count>, C<x_index>, C<x_keys>, C<x_values>, C<x_each>, C<x_exists>,
C<x_delete>, C<x_set>, C<x_get>.
Methods available are:
=head3 C<*>
I<Created by default>. 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<replace> 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<Created by default>. 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<n>,
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<Created by default>. Empty the component of all elements, but without
deleting the storage itself.
If given a list of keys, then the elements I<that exist> 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<b> in component 'a' to undef (if C<b>) already exists (so C<<
$x->a_isset('b')) >> returns true), but C<< $x->a_clear() >> deletes the
element C<b> from component 'a' (so C<< $x->a_isset('b')) >> returns false).
=head3 C<*_isset>
I<Created by default>. 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<a>. I<*_isset(a,b)> tests the elements indexed by I<a>, I<b>,
and returns the logical conjunction (I<and>) of the tests.
=head3 C<*_count>
I<Created by default>. Returns the number of elements in this component.
This is not affected by presence (or lack) of a C<default> (or
C<default_ctor>). Returns C<undef> if whole component not set (as per
I<*_isset>).
=head3 C<*_index>
I<Created by default>. 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<Created by default>. 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<Created by default>. The known values, as a list in list context, as an
arrayref in scalar context.
=head3 C<*_each>
I<Created by default>. The next pair of key, value (as a list) from the hash.
=head3 C<*_exists>
I<Created by default>. Takes any number of arguments, considers each as a
key, and determines whether the key exists in the has. Returns the logical
conjunction (I<and>).
=head3 C<*_delete>
I<Created by default>. This operates exactly like I<*_reset>, except that
calling this with no args does nothing. This is provided for orthogonality
with the Perl C<delete> 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<Created by default>. 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<Created by default>. 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 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 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 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 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 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 typex - store_cb
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 static - typex - store_cb
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 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 static - read_cb
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 typex - read_cb
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 static - typex - read_cb
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 store_cb - read_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 static - store_cb - read_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 typex - store_cb - read_cb
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 static - typex - store_cb - read_cb
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_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 static - default_ctor
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 typex - default_ctor
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 static - typex - default_ctor
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 store_cb - default_ctor
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 static - store_cb - default_ctor
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 typex - store_cb - default_ctor
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 static - typex - store_cb - default_ctor
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 - default_ctor
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 - read_cb - default_ctor
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 typex - read_cb - default_ctor
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 - read_cb - default_ctor
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 - read_cb - default_ctor
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 - read_cb - default_ctor
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 typex - store_cb - read_cb - default_ctor
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 - typex - store_cb - read_cb - default_ctor
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 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 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 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 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 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 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 typex - store_cb - 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 static - typex - store_cb - 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 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 static - read_cb - 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 typex - read_cb - 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 static - typex - read_cb - 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 store_cb - read_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 static - store_cb - read_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 typex - store_cb - read_cb - 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 static - typex - store_cb - read_cb - 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_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 static - default_ctor - 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 typex - default_ctor - 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 static - typex - default_ctor - 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 store_cb - default_ctor - 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 static - store_cb - default_ctor - 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 typex - store_cb - default_ctor - 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 static - typex - store_cb - default_ctor - 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 - default_ctor - 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 - read_cb - default_ctor - 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 typex - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 typex - store_cb - read_cb - default_ctor - 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 - typex - store_cb - read_cb - default_ctor - 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
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 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 typex - tie_class
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 static - typex - tie_class
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 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 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 typex - store_cb - tie_class
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 static - typex - store_cb - tie_class
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 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 static - read_cb - 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 typex - read_cb - tie_class
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 static - typex - read_cb - tie_class
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 store_cb - read_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 static - store_cb - read_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 typex - store_cb - read_cb - tie_class
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 static - typex - store_cb - read_cb - tie_class
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_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 static - default_ctor - 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 typex - default_ctor - tie_class
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 static - typex - default_ctor - tie_class
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 store_cb - default_ctor - 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 static - store_cb - default_ctor - 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 typex - store_cb - default_ctor - tie_class
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 static - typex - store_cb - default_ctor - tie_class
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 - default_ctor - 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 - read_cb - default_ctor - 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 typex - read_cb - default_ctor - tie_class
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 - typex - read_cb - default_ctor - tie_class
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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 typex - store_cb - read_cb - default_ctor - tie_class
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 - typex - store_cb - read_cb - default_ctor - tie_class
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 - tie_class
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 static - v1_compat - tie_class
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 typex - v1_compat - tie_class
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 static - typex - v1_compat - tie_class
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 store_cb - v1_compat - tie_class
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 static - store_cb - v1_compat - tie_class
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 typex - store_cb - v1_compat - tie_class
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 static - typex - store_cb - v1_compat - tie_class
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 read_cb - v1_compat - tie_class
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 static - read_cb - v1_compat - tie_class
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 typex - read_cb - v1_compat - tie_class
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 static - typex - read_cb - v1_compat - tie_class
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 store_cb - read_cb - v1_compat - tie_class
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 static - store_cb - read_cb - v1_compat - tie_class
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 typex - store_cb - read_cb - v1_compat - tie_class
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 static - typex - store_cb - read_cb - v1_compat - tie_class
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_ctor - v1_compat - tie_class
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 static - default_ctor - v1_compat - tie_class
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 typex - default_ctor - v1_compat - tie_class
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 static - typex - default_ctor - v1_compat - tie_class
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 store_cb - default_ctor - v1_compat - tie_class
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 static - store_cb - default_ctor - v1_compat - tie_class
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 typex - store_cb - default_ctor - v1_compat - tie_class
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 static - typex - store_cb - default_ctor - v1_compat - tie_class
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 - default_ctor - v1_compat - tie_class
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 - read_cb - default_ctor - v1_compat - tie_class
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 typex - read_cb - default_ctor - v1_compat - tie_class
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 - typex - read_cb - default_ctor - v1_compat - tie_class
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 - read_cb - default_ctor - v1_compat - tie_class
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 - read_cb - default_ctor - v1_compat - tie_class
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 typex - store_cb - read_cb - default_ctor - v1_compat - tie_class
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 - typex - store_cb - read_cb - default_ctor - v1_compat - tie_class
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;
}
#------------------
# 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 static - default
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 typex - default
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 static - typex - default
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 store_cb - default
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 static - store_cb - default
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 typex - store_cb - default
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 static - typex - store_cb - default
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 read_cb - default
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 static - read_cb - default
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 typex - read_cb - default
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 static - typex - read_cb - default
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 store_cb - read_cb - default
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 static - store_cb - read_cb - default
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 typex - store_cb - read_cb - default
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 static - typex - store_cb - read_cb - default
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 v1_compat - default
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 static - v1_compat - default
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 typex - v1_compat - default
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 static - typex - v1_compat - default
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 store_cb - v1_compat - default
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 static - store_cb - v1_compat - default
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 typex - store_cb - v1_compat - default
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 static - typex - store_cb - v1_compat - default
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 read_cb - v1_compat - default
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 static - read_cb - v1_compat - default
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 typex - read_cb - v1_compat - default
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 static - typex - read_cb - v1_compat - default
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 store_cb - read_cb - v1_compat - default
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 static - store_cb - read_cb - v1_compat - default
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 typex - store_cb - read_cb - v1_compat - default
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 static - typex - store_cb - read_cb - v1_compat - default
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 tie_class - default
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 static - tie_class - default
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 typex - tie_class - default
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 static - typex - tie_class - default
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 store_cb - tie_class - default
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 static - store_cb - tie_class - default
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 typex - store_cb - tie_class - default
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 static - typex - store_cb - tie_class - default
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 read_cb - tie_class - default
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 static - read_cb - tie_class - default
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 typex - read_cb - tie_class - default
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 static - typex - read_cb - tie_class - default
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 store_cb - read_cb - tie_class - default
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 static - store_cb - read_cb - tie_class - default
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 typex - store_cb - read_cb - tie_class - default
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 static - typex - store_cb - read_cb - tie_class - default
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 v1_compat - tie_class - default
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 static - v1_compat - tie_class - default
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 typex - v1_compat - tie_class - default
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 static - typex - v1_compat - tie_class - default
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 store_cb - v1_compat - tie_class - default
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 static - store_cb - v1_compat - tie_class - default
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 typex - store_cb - v1_compat - tie_class - default
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 static - typex - store_cb - v1_compat - tie_class - default
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 read_cb - v1_compat - tie_class - default
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 static - read_cb - v1_compat - tie_class - default
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 typex - read_cb - v1_compat - tie_class - default
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 static - typex - read_cb - v1_compat - tie_class - default
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 store_cb - read_cb - v1_compat - tie_class - default
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 static - store_cb - read_cb - v1_compat - tie_class - default
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 typex - store_cb - read_cb - v1_compat - tie_class - default
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 static - typex - store_cb - read_cb - v1_compat - tie_class - default
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 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 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 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 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 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 static - read_cb - 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 store_cb - read_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 static - store_cb - read_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_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 static - default_ctor - 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 store_cb - default_ctor - 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 static - store_cb - default_ctor - 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 - default_ctor - 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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 v1_compat - type
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 static - v1_compat - type
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 store_cb - v1_compat - type
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 static - store_cb - v1_compat - type
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 read_cb - v1_compat - type
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 static - read_cb - v1_compat - type
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 store_cb - read_cb - v1_compat - type
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 static - store_cb - read_cb - v1_compat - type
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_ctor - v1_compat - type
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 static - default_ctor - v1_compat - type
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 store_cb - default_ctor - v1_compat - type
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 static - store_cb - default_ctor - v1_compat - type
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 - default_ctor - v1_compat - type
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 - read_cb - default_ctor - v1_compat - type
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 - read_cb - default_ctor - v1_compat - type
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 - read_cb - default_ctor - v1_compat - type
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
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 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 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 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 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 static - read_cb - 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 store_cb - read_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 static - store_cb - read_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_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 static - default_ctor - 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 store_cb - default_ctor - 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 static - store_cb - default_ctor - 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 - default_ctor - 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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 - read_cb - default_ctor - 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 v1_compat - tie_class - type
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 static - v1_compat - tie_class - type
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 store_cb - v1_compat - tie_class - type
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 static - store_cb - v1_compat - tie_class - type
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 read_cb - v1_compat - tie_class - type
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 static - read_cb - v1_compat - tie_class - type
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 store_cb - read_cb - v1_compat - tie_class - type
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 static - store_cb - read_cb - v1_compat - tie_class - type
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_ctor - v1_compat - tie_class - type
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 static - default_ctor - v1_compat - tie_class - type
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 store_cb - default_ctor - v1_compat - tie_class - type
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 static - store_cb - default_ctor - v1_compat - tie_class - type
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 - default_ctor - v1_compat - tie_class - type
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 - read_cb - default_ctor - v1_compat - tie_class - type
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 - read_cb - default_ctor - v1_compat - tie_class - type
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 - read_cb - default_ctor - v1_compat - tie_class - type
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 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 static - default - 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 store_cb - default - 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 static - store_cb - default - 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 read_cb - default - 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 static - read_cb - default - 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 store_cb - read_cb - default - 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 static - store_cb - read_cb - default - 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 v1_compat - default - type
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 static - v1_compat - default - type
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 store_cb - v1_compat - default - type
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 static - store_cb - v1_compat - default - type
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 read_cb - v1_compat - default - type
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 static - read_cb - v1_compat - default - type
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 store_cb - read_cb - v1_compat - default - type
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 static - store_cb - read_cb - v1_compat - default - type
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 tie_class - default - 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 static - tie_class - default - 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 store_cb - tie_class - default - 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 static - store_cb - tie_class - default - 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 read_cb - tie_class - default - 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 static - read_cb - tie_class - default - 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 store_cb - read_cb - tie_class - default - 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 static - store_cb - read_cb - tie_class - default - 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 v1_compat - tie_class - default - type
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 static - v1_compat - tie_class - default - type
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 store_cb - v1_compat - tie_class - default - type
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 static - store_cb - v1_compat - tie_class - default - type
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 read_cb - v1_compat - tie_class - default - type
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 static - read_cb - v1_compat - tie_class - default - type
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 store_cb - read_cb - v1_compat - tie_class - default - type
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 static - store_cb - read_cb - v1_compat - tie_class - default - type
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;
}
#------------------------------------
1; # keep require happy