package Class::MethodMaker::scalar;
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::scalar - Create methods for handling a scalar value.
=head1 SYNOPSIS
package MyClass;
use Class::MethodMaker
[ scalar => [qw/ a -static s /]];
sub new {
my $class = shift;
bless {}, $class;
}
package main;
my $m = MyClass->new;
my $a, $x;
$a = $m->a; # *undef*
$x = $m->a_isset; # false
$a = $m->a(1); # 1
$m->a(3);
$x = $m->a_isset; # true
$a = $m->a; # 3
$a = $m->a(5); # 5;
$m->a_reset;
$x = $m->a_isset; # false
=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_isset>, C<x_clear>.
Methods available are:
=head3 C<*>
$m->a(3);
$a = $m->a; # 3
$a = $m->a(5); # 5;
I<Created by default>. If an argument is provided, the component is set to
that value. The method returns the value of the component (after assignment
to a provided value, if appropriate).
=head3 C<*_reset>
$m->a_reset;
I<Created by default>. Resets the component back to its default. 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.
B<Advanced Note>: actually, defaults are assigned as needed: typically, the
next time a the value of a component is read.
=head3 C<*_isset>
print $m->a_isset ? "true" : "false";
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.
=head3 C<*_clear>
$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 by default>. 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<*_get>
package MyClass;
use Class::MethodMaker
[ scalar => [{'*_get' => '*_get'}, 'a'],
new => new, ];
package main;
my $m = MyClass->new;
$m->a(3);
$a = $m->a_get; # 3
$a = $m->a_get(5); # 3; ignores argument
$a = $m->a_get(5); # 3; unchanged by previous call
I<Created on request>. Retrieves the value of the component without setting
(ignores any arguments passed).
=head3 C<*_set>
package MyClass;
use Class::MethodMaker
[ scalar => [{'*_set' => '*_set'}, 'a'],
new => new, ];
package main;
my $m = MyClass->new;
$m->a(3);
$a = $m->a_set; # *undef*
$a = $m->a_set(5); # *undef*; value is set but not returned
$a = $m->a; # 5
I<Created on request>. Sets the component to the first argument (or undef if
no argument provided). Returns no value.
=cut
#------------------
# scalar
sub scal0000 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$_[0]->{$name}
} else {
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default
sub scal0004 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex
sub scal0100 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$_[0]->{$name}
} else {
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);
}
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex
sub scal0104 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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);
}
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type
sub scal0002 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$_[0]->{$name}
} else {
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);
}
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type
sub scal0006 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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);
}
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat
sub scal0020 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
$_[0]->{$name}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat
sub scal0024 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat
sub scal0120 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
$_[0]->{$name}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat
sub scal0124 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat
sub scal0022 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
$_[0]->{$name}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat
sub scal0026 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor
sub scal0008 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor
sub scal0108 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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);
}
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor
sub scal000a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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);
}
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor
sub scal0028 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor
sub scal0128 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor
sub scal002a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb
sub scal0040 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb
sub scal0044 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb
sub scal0140 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb
sub scal0144 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb
sub scal0042 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb
sub scal0046 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb
sub scal0060 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb
sub scal0064 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb
sub scal0160 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb
sub scal0164 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb
sub scal0062 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb
sub scal0066 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb
sub scal0048 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb
sub scal0148 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb
sub scal004a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb
sub scal0068 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb
sub scal0168 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb
sub scal006a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar static
sub scal0001 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$store[0]
} else {
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - static
sub scal0005 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
$store[0] = $default
}
$store[0]
} else {
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - static
sub scal0101 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$store[0]
} else {
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);
}
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - static
sub scal0105 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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);
}
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - static
sub scal0003 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$store[0]
} else {
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);
}
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - static
sub scal0007 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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);
}
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - static
sub scal0021 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
$store[0]
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - static
sub scal0025 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
$store[0] = $default
}
$store[0]
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - static
sub scal0121 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
$store[0]
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - static
sub scal0125 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - static
sub scal0023 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
$store[0]
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - static
sub scal0027 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - static
sub scal0009 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
$store[0]
} else {
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - static
sub scal0109 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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);
}
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - static
sub scal000b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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);
}
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - static
sub scal0029 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
$store[0]
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - static
sub scal0129 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - static
sub scal002b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - static
sub scal0041 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - static
sub scal0045 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - static
sub scal0141 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - static
sub scal0145 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - static
sub scal0043 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - static
sub scal0047 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - static
sub scal0061 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - static
sub scal0065 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - static
sub scal0161 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - static
sub scal0165 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - static
sub scal0063 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - static
sub scal0067 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - static
sub scal0049 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - static
sub scal0149 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - static
sub scal004b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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);
}
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - static
sub scal0069 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - static
sub scal0169 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - static
sub scal006b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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);
}
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar store_cb
sub scal0080 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - store_cb
sub scal0084 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - store_cb
sub scal0180 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - store_cb
sub scal0184 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - store_cb
sub scal0082 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - store_cb
sub scal0086 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - store_cb
sub scal00a0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - store_cb
sub scal00a4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - store_cb
sub scal01a0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - store_cb
sub scal01a4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - store_cb
sub scal00a2 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - store_cb
sub scal00a6 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - store_cb
sub scal0088 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - store_cb
sub scal0188 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - store_cb
sub scal008a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - store_cb
sub scal00a8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - store_cb
sub scal01a8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - store_cb
sub scal00aa {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - store_cb
sub scal00c0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - store_cb
sub scal00c4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - store_cb
sub scal01c0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - store_cb
sub scal01c4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - store_cb
sub scal00c2 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - store_cb
sub scal00c6 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - store_cb
sub scal00e0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - store_cb
sub scal00e4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - store_cb
sub scal01e0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - store_cb
sub scal01e4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - store_cb
sub scal00e2 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - store_cb
sub scal00e6 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - store_cb
sub scal00c8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - store_cb
sub scal01c8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - store_cb
sub scal00ca {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - store_cb
sub scal00e8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
if ( ! exists $_[0]->{$name} ) {
my $default = $dctor->($_[0]);
$_[0]->{$name} = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - store_cb
sub scal01e8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - store_cb
sub scal00ea {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar static - store_cb
sub scal0081 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - static - store_cb
sub scal0085 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
$store[0] = $default
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - static - store_cb
sub scal0181 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - static - store_cb
sub scal0185 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - static - store_cb
sub scal0083 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - static - store_cb
sub scal0087 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - static - store_cb
sub scal00a1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - static - store_cb
sub scal00a5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
$store[0] = $default
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - static - store_cb
sub scal01a1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - static - store_cb
sub scal01a5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - static - store_cb
sub scal00a3 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - static - store_cb
sub scal00a7 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - static - store_cb
sub scal0089 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - static - store_cb
sub scal0189 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - static - store_cb
sub scal008b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - static - store_cb
sub scal00a9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - static - store_cb
sub scal01a9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - static - store_cb
sub scal00ab {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - static - store_cb
sub scal00c1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - static - store_cb
sub scal00c5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - static - store_cb
sub scal01c1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - static - store_cb
sub scal01c5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - static - store_cb
sub scal00c3 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - static - store_cb
sub scal00c7 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - static - store_cb
sub scal00e1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - static - store_cb
sub scal00e5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - static - store_cb
sub scal01e1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - static - store_cb
sub scal01e5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - static - store_cb
sub scal00e3 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - static - store_cb
sub scal00e7 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - static - store_cb
sub scal00c9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - static - store_cb
sub scal01c9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - static - store_cb
sub scal00cb {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - static - store_cb
sub scal00e9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
if ( ! exists $store[0] ) {
my $default = $dctor->($_[0]);
$store[0] = $default
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - static - store_cb
sub scal01e9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - static - store_cb
sub scal00eb {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar tie_class
sub scal0010 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - tie_class
sub scal0014 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - tie_class
sub scal0110 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
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};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - tie_class
sub scal0114 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - tie_class
sub scal0012 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
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};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - tie_class
sub scal0016 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - tie_class
sub scal0030 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - tie_class
sub scal0034 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - tie_class
sub scal0130 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - tie_class
sub scal0134 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - tie_class
sub scal0032 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - tie_class
sub scal0036 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - tie_class
sub scal0018 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - tie_class
sub scal0118 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - tie_class
sub scal001a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
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};
$_[0]->{$name} = $_[1];
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - tie_class
sub scal0038 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - tie_class
sub scal0138 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - tie_class
sub scal003a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - tie_class
sub scal0050 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - tie_class
sub scal0054 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - tie_class
sub scal0150 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - tie_class
sub scal0154 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - tie_class
sub scal0052 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - tie_class
sub scal0056 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - tie_class
sub scal0070 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - tie_class
sub scal0074 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - tie_class
sub scal0170 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - tie_class
sub scal0174 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - tie_class
sub scal0072 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - tie_class
sub scal0076 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - tie_class
sub scal0058 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - tie_class
sub scal0158 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - tie_class
sub scal005a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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};
$_[0]->{$name} = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - tie_class
sub scal0078 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - tie_class
sub scal0178 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - tie_class
sub scal007a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar static - tie_class
sub scal0011 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - static - tie_class
sub scal0015 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - static - tie_class
sub scal0111 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
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];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - static - tie_class
sub scal0115 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - static - tie_class
sub scal0013 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
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];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - static - tie_class
sub scal0017 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - static - tie_class
sub scal0031 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - static - tie_class
sub scal0035 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - static - tie_class
sub scal0131 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - static - tie_class
sub scal0135 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - static - tie_class
sub scal0033 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - static - tie_class
sub scal0037 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - static - tie_class
sub scal0019 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - static - tie_class
sub scal0119 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - static - tie_class
sub scal001b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
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];
$store[0] = $_[1];
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - static - tie_class
sub scal0039 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - static - tie_class
sub scal0139 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - static - tie_class
sub scal003b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - static - tie_class
sub scal0051 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - static - tie_class
sub scal0055 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - static - tie_class
sub scal0151 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - static - tie_class
sub scal0155 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - static - tie_class
sub scal0053 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - static - tie_class
sub scal0057 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - static - tie_class
sub scal0071 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - static - tie_class
sub scal0075 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - static - tie_class
sub scal0171 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - static - tie_class
sub scal0175 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - static - tie_class
sub scal0073 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - static - tie_class
sub scal0077 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - static - tie_class
sub scal0059 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - static - tie_class
sub scal0159 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - static - tie_class
sub scal005b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
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];
$store[0] = $_[1];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - static - tie_class
sub scal0079 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - static - tie_class
sub scal0179 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - static - tie_class
sub scal007b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
unless ( $v1object ) {
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];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $_[1]
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar store_cb - tie_class
sub scal0090 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - store_cb - tie_class
sub scal0094 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - store_cb - tie_class
sub scal0190 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - store_cb - tie_class
sub scal0194 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - store_cb - tie_class
sub scal0092 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - store_cb - tie_class
sub scal0096 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - store_cb - tie_class
sub scal00b0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - store_cb - tie_class
sub scal00b4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - store_cb - tie_class
sub scal01b0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - store_cb - tie_class
sub scal01b4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - store_cb - tie_class
sub scal00b2 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - store_cb - tie_class
sub scal00b6 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - store_cb - tie_class
sub scal0098 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - store_cb - tie_class
sub scal0198 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - store_cb - tie_class
sub scal009a {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - store_cb - tie_class
sub scal00b8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - store_cb - tie_class
sub scal01b8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - store_cb - tie_class
sub scal00ba {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - store_cb - tie_class
sub scal00d0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - store_cb - tie_class
sub scal00d4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - store_cb - tie_class
sub scal01d0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - store_cb - tie_class
sub scal01d4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - store_cb - tie_class
sub scal00d2 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - store_cb - tie_class
sub scal00d6 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - store_cb - tie_class
sub scal00f0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - store_cb - tie_class
sub scal00f4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - store_cb - tie_class
sub scal01f0 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - store_cb - tie_class
sub scal01f4 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - store_cb - tie_class
sub scal00f2 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - store_cb - tie_class
sub scal00f6 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - store_cb - tie_class
sub scal00d8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - store_cb - tie_class
sub scal01d8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - store_cb - tie_class
sub scal00da {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
$_[0]->{$name} = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - store_cb - tie_class
sub scal00f8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $_[0]->{$name}, $tie_class, @tie_args
unless exists $_[0]->{$name};
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - store_cb - tie_class
sub scal01f8 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - store_cb - tie_class
sub scal00fa {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$_[0]->{$name} = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $_[0]->{$name} ) {
my $old = $_[0]->{$name};
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$_[0]->{$name} = $_[1];
} else {
$_[0]->{$name} = $dctor->(@_[1..$#_]);
}
} else {
$_[0]->{$name} = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $_[0]->{$name};
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $_[0]->{$name};
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $_[0]->{$name};
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar static - store_cb - tie_class
sub scal0091 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - static - store_cb - tie_class
sub scal0095 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - static - store_cb - tie_class
sub scal0191 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - static - store_cb - tie_class
sub scal0195 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - static - store_cb - tie_class
sub scal0093 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - static - store_cb - tie_class
sub scal0097 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - static - store_cb - tie_class
sub scal00b1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - static - store_cb - tie_class
sub scal00b5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - static - store_cb - tie_class
sub scal01b1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - static - store_cb - tie_class
sub scal01b5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - static - store_cb - tie_class
sub scal00b3 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - static - store_cb - tie_class
sub scal00b7 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - static - store_cb - tie_class
sub scal0099 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - static - store_cb - tie_class
sub scal0199 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - static - store_cb - tie_class
sub scal009b {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - static - store_cb - tie_class
sub scal00b9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - static - store_cb - tie_class
sub scal01b9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - static - store_cb - tie_class
sub scal00bb {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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]
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar read_cb - static - store_cb - tie_class
sub scal00d1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - read_cb - static - store_cb - tie_class
sub scal00d5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - read_cb - static - store_cb - tie_class
sub scal01d1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - read_cb - static - store_cb - tie_class
sub scal01d5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - read_cb - static - store_cb - tie_class
sub scal00d3 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - read_cb - static - store_cb - tie_class
sub scal00d7 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - read_cb - static - store_cb - tie_class
sub scal00f1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - v1_compat - read_cb - static - store_cb - tie_class
sub scal00f5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - read_cb - static - store_cb - tie_class
sub scal01f1 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - typex - v1_compat - read_cb - static - store_cb - tie_class
sub scal01f5 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - read_cb - static - store_cb - tie_class
sub scal00f3 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default - type - v1_compat - read_cb - static - store_cb - tie_class
sub scal00f7 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar default_ctor - read_cb - static - store_cb - tie_class
sub scal00d9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - default_ctor - read_cb - static - store_cb - tie_class
sub scal01d9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute $name: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
# (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
# '*undef*'
# ), $typex))
# unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - default_ctor - read_cb - static - store_cb - tie_class
sub scal00db {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old)
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name)
for @store_callbacks;
}
for ($v) {
croak(sprintf("Incorrect type for attribute $name: %s\n" .
" : should be '%s' (or subclass thereof)\n",
(defined($_) ?
(ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
'*undef*'
), $type))
unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
$store[0] = $v;
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar v1_compat - default_ctor - read_cb - static - store_cb - tie_class
sub scal00f9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
tie $store[0], $tie_class, @tie_args
unless exists $store[0];
}
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar typex - v1_compat - default_ctor - read_cb - static - store_cb - tie_class
sub scal01f9 {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------
# scalar type - v1_compat - default_ctor - read_cb - static - store_cb - tie_class
sub scal00fb {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
my @store;
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
my %methods =
( '*' => sub : method {
my $z = \@_; # work around stack problems
if ( @_ == 1 ) {
if ( $v1object and ! exists $_[0]->{$name} ) {
$store[0] = $dctor->();
}
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
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
} else {
my $v = $_[1];
if ( exists $store[0] ) {
my $old = $store[0];
$v = $_->($_[0], $v, $name, $old, @_[1..$#_])
for @store_callbacks;
} else {
$v = $_->($_[0], $v, $name, undef, @_[1..$#_])
for @store_callbacks;
}
unless ( $v1object ) {
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 ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
$store[0] = $_[1];
} else {
$store[0] = $dctor->(@_[1..$#_]);
}
} else {
$store[0] = $v
}
{ # Encapsulate scope to avoid redefined $v issues
my $v = $store[0];
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
}
},
'*_reset' => sub : method {
delete $store[0];
},
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists $store[0];
}
),
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
'INTEGER:*_incr' => sub {
my $x = $names{'*'};
my $incr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()+$incr);
},
'INTEGER:*_decr' => sub {
my $x = $names{'*'};
my $decr = @_ > 1 ? $_[1] : 1;
$_[0]->$x($_[0]->$x()-$decr);
},
'INTEGER:*_zero' => sub {
my $x = $names{'*'};
$_[0]->$x(0);
},
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}
#------------------------------------
1; # keep require happy