shell bypass 403
package Class::MethodMaker::array;
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::array - Create methods for handling an array value.
=head1 SYNOPSIS
use Class::MethodMaker
[ array => [qw/ x /] ];
$instance->x; # empty
$instance->x(1, 1, 2, 3, 5, 8);
$instance->x_count == 6; # true
$instance->x = (13, 21, 34);
$instance->x_index(1) == 21; # true
=head1 DESCRIPTION
Creates methods to handle array 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_push>, C<x_pop>, C<x_unshift>, C<x_shift>,
C<x_splice>.
Methods available are:
=head3 C<*>
I<Created by default.> This method returns the list of values stored in the
slot. If any arguments are provided to this method, they B<replace> the
current list contents. In an array context it returns the values as an array
and in a scalar context as a reference to an array. 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.) This
function no longer auto-expands arrayrefs input as arguments, since that makes
it awkward to set individual values to arrayrefs. See x_setref for that
functionality.
If a default value is in force, then that value will be auto-vivified (and
therefore set) for each otherwise I<unset> (not I<not defined>) value up to
the array max (so new items will not be appended)
=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 C<*_isset> will return false,
and C<*> will return undef. If C<-default> is in effect, then the component
will be set to the default value, and C<*_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 C<*_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 C<*_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>
package MyClass;
use Class::MethodMaker
[ scalar => [{'*_clear' => '*_clear'}, 'a'],
new => new, ];
package main;
my $m = MyClass->new;
$m->a(5);
$a = $m->a; # 5
$x = $m->a_isset; # true
$m->a_clear;
$a = $m->a; # *undef*
$x = $m->a_isset; # true
I<Created on request>. A shorthand for setting to undef. Note that the
component will be set to undef, not reset, so C<*_isset> will return true.
=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 <*_reset>.
If a default value is in effect, then <*_isset> will always return true.
C<*_isset()> tests the component as a whole. C<*_isset(a)> tests the element
indexed by I<a>. C<*_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 C<*_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).
Beware of a bug in perl 5.6.1 that will sometimes invent values in
previously unset slots of arrays that previously contained a value.
So, vivifying a value (e.g. by x_index(2)) where x_index(1) was
previously unset might cause x_index(1) to be set spuriously. This
is fixed in 5.8.0.
=head3 C<*_push>
I<Created by default.> Push item(s) onto the end of the list. No return
value.
=head3 C<*_pop>
I<Created by default.> Given a number, pops that many items off the end of the
list, and returns them (as a ref in scalar context, as a list in list
context). Without an arg, always returns a single element. Given a number,
returns them in array order (not in reverse order as multiple pops would).
=head3 C<*_unshift>
I<Created by default.> Push item(s) onto the start of the list. No return
value.
=head3 C<*_shift>
I<Created by default.> Given a number, shifts that many items off the start of
the list, and returns them (as a ref in scalar context, as a list in list
context). Without an arg, always returns a single element. Given a number,
returns them in array order.
=head3 C<*_splice>
I<Created by default.> Arguments as for L<perldoc perlfunc splice|splice>.
Returns an arrayref in scalar context (even if a single item is spliced), and
a list in list context.
=head3 C<*_get>
I<Created on request>. Retrieves the value of the component without setting
(ignores any arguments passed).
=head3 C<*_set>
@n = $x->a; # (1,2,3)
$x->a_set(1=>4,3=>7);
@n = $x->a; # (1,4,3,7)
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(1=>4,3=>7);
$x->a_set([1,3],[4,7]);
=cut
#------------------
# array
sub arra0000 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex
sub arra0100 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb
sub arra0080 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb
sub arra0180 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class
sub arra0010 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class
sub arra0110 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class
sub arra0090 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class
sub arra0190 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor
sub arra0008 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor
sub arra0108 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor
sub arra0088 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor
sub arra0188 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor
sub arra0018 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor
sub arra0118 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor
sub arra0098 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor
sub arra0198 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default
sub arra0004 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default
sub arra0104 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default
sub arra0084 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default
sub arra0184 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default
sub arra0014 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default
sub arra0114 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default
sub arra0094 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default
sub arra0194 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat
sub arra0020 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - v1_compat
sub arra0120 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat
sub arra00a0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - v1_compat
sub arra01a0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat
sub arra0030 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - v1_compat
sub arra0130 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat
sub arra00b0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - v1_compat
sub arra01b0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat
sub arra0028 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - v1_compat
sub arra0128 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat
sub arra00a8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - v1_compat
sub arra01a8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat
sub arra0038 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - v1_compat
sub arra0138 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat
sub arra00b8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - v1_compat
sub arra01b8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat
sub arra0024 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - v1_compat
sub arra0124 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat
sub arra00a4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - v1_compat
sub arra01a4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat
sub arra0034 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - v1_compat
sub arra0134 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat
sub arra00b4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - v1_compat
sub arra01b4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array static
sub arra0001 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - static
sub arra0101 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - static
sub arra0081 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - static
sub arra0181 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - static
sub arra0011 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - static
sub arra0111 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - static
sub arra0091 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - static
sub arra0191 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - static
sub arra0009 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - static
sub arra0109 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - static
sub arra0089 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - static
sub arra0189 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - static
sub arra0019 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - static
sub arra0119 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - static
sub arra0099 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - static
sub arra0199 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - static
sub arra0005 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - static
sub arra0105 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - static
sub arra0085 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - static
sub arra0185 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - static
sub arra0015 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - static
sub arra0115 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - static
sub arra0095 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - static
sub arra0195 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - static
sub arra0021 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - v1_compat - static
sub arra0121 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - static
sub arra00a1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - v1_compat - static
sub arra01a1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - static
sub arra0031 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - v1_compat - static
sub arra0131 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - static
sub arra00b1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - v1_compat - static
sub arra01b1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - static
sub arra0029 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - v1_compat - static
sub arra0129 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - static
sub arra00a9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - v1_compat - static
sub arra01a9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - static
sub arra0039 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - v1_compat - static
sub arra0139 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - static
sub arra00b9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - v1_compat - static
sub arra01b9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - static
sub arra0025 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - v1_compat - static
sub arra0125 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - static
sub arra00a5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - v1_compat - static
sub arra01a5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - static
sub arra0035 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - v1_compat - static
sub arra0135 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - static
sub arra00b5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - v1_compat - static
sub arra01b5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array type
sub arra0002 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - type
sub arra0082 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - type
sub arra0012 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - type
sub arra0092 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - type
sub arra000a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - type
sub arra008a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - type
sub arra001a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - type
sub arra009a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - type
sub arra0006 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - type
sub arra0086 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - type
sub arra0016 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - type
sub arra0096 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - type
sub arra0022 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - type
sub arra00a2 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - type
sub arra0032 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - type
sub arra00b2 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - type
sub arra002a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - type
sub arra00aa {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - type
sub arra003a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - type
sub arra00ba {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - type
sub arra0026 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - type
sub arra00a6 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - type
sub arra0036 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - type
sub arra00b6 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array static - type
sub arra0003 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - static - type
sub arra0083 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - static - type
sub arra0013 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - static - type
sub arra0093 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - static - type
sub arra000b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - static - type
sub arra008b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - static - type
sub arra001b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - static - type
sub arra009b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - static - type
sub arra0007 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - static - type
sub arra0087 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - static - type
sub arra0017 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - static - type
sub arra0097 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - static - type
sub arra0023 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - static - type
sub arra00a3 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - static - type
sub arra0033 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - static - type
sub arra00b3 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - static - type
sub arra002b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - static - type
sub arra00ab {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - static - type
sub arra003b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - static - type
sub arra00bb {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - static - type
sub arra0027 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - static - type
sub arra00a7 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - static - type
sub arra0037 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - static - type
sub arra00b7 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array read_cb
sub arra0040 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - read_cb
sub arra0140 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - read_cb
sub arra00c0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - read_cb
sub arra01c0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - read_cb
sub arra0050 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - read_cb
sub arra0150 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - read_cb
sub arra00d0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - read_cb
sub arra01d0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - read_cb
sub arra0048 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - read_cb
sub arra0148 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - read_cb
sub arra00c8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - read_cb
sub arra01c8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - read_cb
sub arra0058 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - read_cb
sub arra0158 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - read_cb
sub arra00d8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - read_cb
sub arra01d8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - read_cb
sub arra0044 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - read_cb
sub arra0144 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - read_cb
sub arra00c4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - read_cb
sub arra01c4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - read_cb
sub arra0054 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - read_cb
sub arra0154 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - read_cb
sub arra00d4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - read_cb
sub arra01d4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - read_cb
sub arra0060 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - v1_compat - read_cb
sub arra0160 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - read_cb
sub arra00e0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - v1_compat - read_cb
sub arra01e0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - read_cb
sub arra0070 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - v1_compat - read_cb
sub arra0170 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - read_cb
sub arra00f0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - v1_compat - read_cb
sub arra01f0 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - read_cb
sub arra0068 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - v1_compat - read_cb
sub arra0168 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - read_cb
sub arra00e8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
my $default = $dctor->($_[0]);
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - v1_compat - read_cb
sub arra01e8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - read_cb
sub arra0078 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - v1_compat - read_cb
sub arra0178 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - read_cb
sub arra00f8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - v1_compat - read_cb
sub arra01f8 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - read_cb
sub arra0064 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - v1_compat - read_cb
sub arra0164 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - read_cb
sub arra00e4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
if ( ! exists ($_[0]->{$name}->[$_]) ) {
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - v1_compat - read_cb
sub arra01e4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - read_cb
sub arra0074 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - v1_compat - read_cb
sub arra0174 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - read_cb
sub arra00f4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
@{$_[0]->{$name}}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$_[0]->{$name}}, $tie_class, @tie_args
unless exists $_[0]->{$name};
${$_[0]->{$name}}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - v1_compat - read_cb
sub arra01f4 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array static - read_cb
sub arra0041 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - static - read_cb
sub arra0141 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - static - read_cb
sub arra00c1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - static - read_cb
sub arra01c1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - static - read_cb
sub arra0051 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - static - read_cb
sub arra0151 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - static - read_cb
sub arra00d1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - static - read_cb
sub arra01d1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - static - read_cb
sub arra0049 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - static - read_cb
sub arra0149 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - static - read_cb
sub arra00c9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - static - read_cb
sub arra01c9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - static - read_cb
sub arra0059 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - static - read_cb
sub arra0159 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - static - read_cb
sub arra00d9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - static - read_cb
sub arra01d9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - static - read_cb
sub arra0045 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - static - read_cb
sub arra0145 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - static - read_cb
sub arra00c5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - static - read_cb
sub arra01c5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - static - read_cb
sub arra0055 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - static - read_cb
sub arra0155 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - static - read_cb
sub arra00d5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - static - read_cb
sub arra01d5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - static - read_cb
sub arra0061 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - v1_compat - static - read_cb
sub arra0161 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - static - read_cb
sub arra00e1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - v1_compat - static - read_cb
sub arra01e1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - static - read_cb
sub arra0071 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - v1_compat - static - read_cb
sub arra0171 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - static - read_cb
sub arra00f1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - v1_compat - static - read_cb
sub arra01f1 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - static - read_cb
sub arra0069 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default_ctor - v1_compat - static - read_cb
sub arra0169 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - static - read_cb
sub arra00e9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
my $default = $dctor->($_[0]);
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default_ctor - v1_compat - static - read_cb
sub arra01e9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - static - read_cb
sub arra0079 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default_ctor - v1_compat - static - read_cb
sub arra0179 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - static - read_cb
sub arra00f9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default_ctor - v1_compat - static - read_cb
sub arra01f9 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - static - read_cb
sub arra0065 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - default - v1_compat - static - read_cb
sub arra0165 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - static - read_cb
sub arra00e5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
if ( ! exists ($store[0]->[$_]) ) {
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, )
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, )
for @store_callbacks;
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - default - v1_compat - static - read_cb
sub arra01e5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - static - read_cb
sub arra0075 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
if ( ! defined $want ) {
@{$store[0]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - tie_class - default - v1_compat - static - read_cb
sub arra0175 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - static - read_cb
sub arra00f5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
@{$store[0]}[@{$_[1]}] = @{$_[2]};
} else {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
tie @{$store[0]}, $tie_class, @tie_args
unless exists $store[0];
${$store[0]}[$_[$_*2-1]] = $_[$_*2]
for 1..($#_/2);
}
return;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array typex - store_cb - tie_class - default - v1_compat - static - read_cb
sub arra01f5 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array type - read_cb
sub arra0042 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - type - read_cb
sub arra00c2 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - type - read_cb
sub arra0052 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - type - read_cb
sub arra00d2 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - type - read_cb
sub arra004a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - type - read_cb
sub arra00ca {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - type - read_cb
sub arra005a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - type - read_cb
sub arra00da {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - type - read_cb
sub arra0046 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - type - read_cb
sub arra00c6 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - type - read_cb
sub arra0056 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - type - read_cb
sub arra00d6 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - type - read_cb
sub arra0062 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - type - read_cb
sub arra00e2 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - type - read_cb
sub arra0072 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - type - read_cb
sub arra00f2 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - type - read_cb
sub arra006a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - type - read_cb
sub arra00ea {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - type - read_cb
sub arra007a {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - type - read_cb
sub arra00fa {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - type - read_cb
sub arra0066 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - type - read_cb
sub arra00e6 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[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);
}
($_[0]->{$name}->[$_]) = $default
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - type - read_cb
sub arra0076 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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}} = @x;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @x;
} else {
[@{$_[0]->{$name}} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - type - read_cb
sub arra00f6 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $_[0]->{$name} ) {
for (0..$#{$_[0]->{$name}}) {
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
}
;
}
}
if ( exists $_[0]->{$name} ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$_[0]->{$name}};
} else {
return [@{$_[0]->{$name}}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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};
if ( ! defined $want ) {
@{$_[0]->{$name}} = @$v;
return;
} elsif ( $want ) {
@{$_[0]->{$name}} = @$v;
} else {
[@{$_[0]->{$name}} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$_[0]->{$name}};
delete $_[0]->{$name};
} else {
delete @{$_[0]->{$name}}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $_[0]->{$name}
} elsif ( @_ == 2 ) {
exists $_[0]->{$name}->[$_[1]]
} else {
return
for grep ! exists $_[0]->{$name}->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $_[0]->{$name} ) {
return scalar @{$_[0]->{$name}};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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};
push @{$_[0]->{$name}}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$_[0]->{$name}};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, -$_[1]] :
splice @{$_[0]->{$name}}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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};
unshift @{$_[0]->{$name}}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$_[0]->{$name}};
} else {
splice @{$_[0]->{$name}}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$_[0]->{$name}}, 0, $_[1]] :
splice @{$_[0]->{$name}}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$_[0]->{$name}}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$_[0]->{$name}}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$_[0]->{$name}} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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};
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$_[0]->{$name}}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $_[0]->{$name} },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array static - type - read_cb
sub arra0043 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - static - type - read_cb
sub arra00c3 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - static - type - read_cb
sub arra0053 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - static - type - read_cb
sub arra00d3 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - static - type - read_cb
sub arra004b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - static - type - read_cb
sub arra00cb {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - static - type - read_cb
sub arra005b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - static - type - read_cb
sub arra00db {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - static - type - read_cb
sub arra0047 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - static - type - read_cb
sub arra00c7 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - static - type - read_cb
sub arra0057 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - static - type - read_cb
sub arra00d7 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
@x = @_[1..$#_];
my $v = \@x;
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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
return;
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
return;
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array v1_compat - static - type - read_cb
sub arra0063 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - v1_compat - static - type - read_cb
sub arra00e3 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - v1_compat - static - type - read_cb
sub arra0073 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - v1_compat - static - type - read_cb
sub arra00f3 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default_ctor - v1_compat - static - type - read_cb
sub arra006b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default_ctor - v1_compat - static - type - read_cb
sub arra00eb {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default_ctor - v1_compat - static - type - read_cb
sub arra007b {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default_ctor - v1_compat - static - type - read_cb
sub arra00fb {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array default - v1_compat - static - type - read_cb
sub arra0067 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for 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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - default - v1_compat - static - type - read_cb
sub arra00e7 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$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);
}
($store[0]->[$_]) = $default
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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);
}
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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);
}
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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);
}
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array tie_class - default - v1_compat - static - type - read_cb
sub arra0077 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
for (@x) {
croak(sprintf("Incorrect type for attribute $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]} = @x;
return;
} elsif ( $want ) {
@{$store[0]} = @x;
} else {
[@{$store[0]} = @x];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------
# array store_cb - tie_class - default - v1_compat - static - type - read_cb
sub arra00f7 {
my $SENTINEL_CLEAR = \1;
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
my %known_options = map {; $_ => 1 } qw( static type forward
default default_ctor
tie_class tie_args
read_cb store_cb
v1_compat );
if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
croak("$prefix not recognized for attribute type hash: ",
join(', ', @bad_opt), "\n");
}
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
my ($default, $dctor, $default_defined);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to array ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
} else {
$dctor = $options->{default_ctor};
croak("Argument to default_ctor must be a simple value or a code ref ",
" (attribute $name)\n")
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
return {
'*' =>
sub : method {
my $z = \@_; # work around stack problems
my $want = wantarray;
print STDERR "W: ", $want, ':', join(',',@_),"\n"
if DEBUG;
# We also deliberately avoid instantiating storage if not
# necessary.
if ( @_ == 1 ) {
if ( exists $store[0] ) {
for (0..$#{$store[0]}) {
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
}
;
}
}
if ( exists $store[0] ) {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return @{$store[0]};
} else {
return [@{$store[0]}];
}
} else {
if ( ! defined $want ) {
return;
} elsif ( $want ) {
return ();
} else {
return [];
}
}
} else {
{
no warnings "numeric";
$#_ = 0
if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
}
my @x;
if ( $options->{tie_class} ) {
@x = @_[1..$#_];
} else {
@x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
}
my $v = \@x;
if ( 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];
if ( ! defined $want ) {
@{$store[0]} = @$v;
return;
} elsif ( $want ) {
@{$store[0]} = @$v;
} else {
[@{$store[0]} = @$v];
}
}
},
'*_reset' =>
sub : method {
if ( @_ == 1 ) {
untie @{$store[0]};
delete $store[0];
} else {
delete @{$store[0]}[@_[1..$#_]];
}
return;
},
'*_clear' =>
sub : method {
my $x = $names{'*'};
$_[0]->$x($SENTINEL_CLEAR);
return;
},
'*_isset' =>
( $default_defined ?
sub : method { 1 } :
sub : method {
if ( @_ == 1 ) {
exists $store[0]
} elsif ( @_ == 2 ) {
exists $store[0]->[$_[1]]
} else {
return
for grep ! exists $store[0]->[$_], @_[1..$#_];
return 1;
}
}
),
'*_count' =>
sub : method {
if ( exists $store[0] ) {
return scalar @{$store[0]};
} else {
return 0;
}
},
# I did try to do 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..$#_]];
}
),
'*_push' =>
sub : method {
for (@_[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];
push @{$store[0]}, @_[1..$#_];
},
'*_pop' =>
sub : method {
if ( @_ == 1 ) {
pop @{$store[0]};
} else {
return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, -$_[1]] :
splice @{$store[0]}, -$_[1] ;
}
},
'*_unshift' =>
sub : method {
for (@_[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];
unshift @{$store[0]}, @_[1..$#_];
},
'*_shift' =>
sub : method {
if ( @_ == 1 ) {
shift @{$store[0]};
} else {
splice @{$store[0]}, 0, $_[1], return
unless defined wantarray;
! wantarray ? [splice @{$store[0]}, 0, $_[1]] :
splice @{$store[0]}, 0, $_[1] ;
}
},
'*_splice' =>
sub : method {
# Disturbing weirdness due to prototype of splice.
# splice @{$store[0]}, @_[1..$#_]
# doesn't work because the prototype wants a scalar for
# argument 2, so the @_[1..$#_] gets evaluated in a scalar
# context, thus counts the elements of @_ (subtract 1).
# Ripping of the head elements
# splice @{$store[0]}, $_[1], $_[2], @_[3..$#_]
# almost works, but that the $_[2] if not present presents an
# undef, which works as a zero, whereas
# splice @{$store[0]}, $_[1]
# splices to the end of the array
if ( @_ < 3 ) {
if ( @_ < 2 ) {
$_[1] = 0;
}
$_[2] = @{$store[0]} - $_[1]
}
for (@_[3..$#_]) {
croak(sprintf("Incorrect type for attribute $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];
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]), return
unless defined wantarray;
! wantarray ? [splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_])] :
splice(@{$store[0]}, $_[1], $_[2], @_[3..$#_]) ;
},
'!*_get' =>
sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'*_set' =>
sub : method {
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 {
croak
sprintf("'%s' requires an even number of args (got %d)\n",
$names{'*_set'}, @_-1)
unless @_ % 2;
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;
},
#
# This method is deprecated. It exists only for v1 compatibility,
# and may change or go away at any time. Caveat Emptor.
#
'!*_ref' =>
sub : method { $store[0] },
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
my @x;
my @y = $_[0]->$x();
@x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
# We don't check for a undefined wantarray here, since
# calling this in a void context is a sufficiently
# nonsensical thing to do that checking for it is likely
# performance hit than the typical saving.
! wantarray ? \@x : @x;
}
} @forward),
}, \%names;
}
#------------------------------------
1; # keep require happy