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, by default creates methods C, C, C, C. Methods available are: =head3 C<*> $m->a(3); $a = $m->a; # 3 $a = $m->a(5); # 5; I. 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. 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: 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. 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. 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. 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. 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 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 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 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 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 v1_compat - type 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 store_cb - type 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 v1_compat - store_cb - type 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 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 v1_compat - typex 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 store_cb - typex 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 v1_compat - store_cb - typex 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_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 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 store_cb - default_ctor 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 v1_compat - store_cb - default_ctor 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 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 - type - 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 store_cb - type - default_ctor 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 - store_cb - type - default_ctor 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 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 v1_compat - typex - 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 store_cb - typex - default_ctor 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 v1_compat - store_cb - typex - default_ctor 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 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 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 store_cb - static 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 v1_compat - store_cb - static 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 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 v1_compat - type - 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 store_cb - type - static 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 v1_compat - store_cb - type - static 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 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 v1_compat - typex - 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 store_cb - typex - static 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 v1_compat - store_cb - typex - static 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_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 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 store_cb - default_ctor - static 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 v1_compat - store_cb - default_ctor - static 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 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 - type - 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 store_cb - type - default_ctor - static 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 - store_cb - type - default_ctor - static 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 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 v1_compat - typex - 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 store_cb - typex - default_ctor - static 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 v1_compat - store_cb - typex - default_ctor - static 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 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 v1_compat - default 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 store_cb - default 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 v1_compat - store_cb - default 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 type - default 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 - type - default 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 store_cb - type - default 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 - type - default 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 typex - default 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 v1_compat - typex - default 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 store_cb - typex - default 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 v1_compat - store_cb - typex - default 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 static - default 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 v1_compat - static - default 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 store_cb - static - default 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 v1_compat - store_cb - static - default 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 type - static - default 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 - type - static - default 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 store_cb - type - static - default 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 - store_cb - type - static - default 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 typex - static - default 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 v1_compat - typex - static - default 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 store_cb - typex - static - default 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 v1_compat - store_cb - typex - static - default 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 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 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 store_cb - read_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 v1_compat - store_cb - read_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 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 v1_compat - type - 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 store_cb - type - read_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 v1_compat - store_cb - type - read_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 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 v1_compat - typex - 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 store_cb - typex - read_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 v1_compat - store_cb - typex - read_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_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 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 store_cb - default_ctor - read_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 v1_compat - store_cb - default_ctor - read_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 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 - type - 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 store_cb - type - default_ctor - read_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 - store_cb - type - default_ctor - read_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 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 v1_compat - typex - 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 store_cb - typex - default_ctor - read_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 v1_compat - store_cb - typex - default_ctor - read_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 static - read_cb 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 v1_compat - static - read_cb 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 store_cb - static - read_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 v1_compat - store_cb - static - read_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 type - static - read_cb 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 v1_compat - type - static - read_cb 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 store_cb - type - static - read_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 v1_compat - store_cb - type - static - read_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 typex - static - read_cb 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 v1_compat - typex - static - read_cb 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 store_cb - typex - static - read_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 v1_compat - store_cb - typex - static - read_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_ctor - static - read_cb 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 v1_compat - default_ctor - static - read_cb 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 store_cb - default_ctor - static - read_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 v1_compat - store_cb - default_ctor - static - read_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 type - default_ctor - static - read_cb 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 - type - default_ctor - static - read_cb 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 - type - default_ctor - static - read_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 - store_cb - type - default_ctor - static - read_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 typex - default_ctor - static - read_cb 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 v1_compat - typex - default_ctor - static - read_cb 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 store_cb - typex - default_ctor - static - read_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 v1_compat - store_cb - typex - default_ctor - static - read_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 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 v1_compat - default - 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 store_cb - default - read_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 v1_compat - store_cb - default - read_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 type - default - 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 - type - default - 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 store_cb - type - default - read_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 - store_cb - type - default - read_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 typex - default - 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 v1_compat - typex - default - 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 store_cb - typex - default - read_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 v1_compat - store_cb - typex - default - read_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 static - default - read_cb 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 v1_compat - static - default - read_cb 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 store_cb - static - default - read_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 v1_compat - store_cb - static - default - read_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 type - static - default - read_cb 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 - type - static - default - read_cb 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 store_cb - type - static - default - read_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 - store_cb - type - static - default - read_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 typex - static - default - read_cb 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 v1_compat - typex - static - default - read_cb 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 store_cb - typex - static - default - read_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 v1_compat - store_cb - typex - static - default - read_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 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 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 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 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 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 v1_compat - type - 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 store_cb - type - 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 v1_compat - store_cb - type - 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 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 v1_compat - typex - 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 store_cb - typex - 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 v1_compat - store_cb - typex - 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_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 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 store_cb - default_ctor - 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 v1_compat - store_cb - default_ctor - 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 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 - type - 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 store_cb - type - default_ctor - 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 - store_cb - type - default_ctor - 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 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 v1_compat - typex - 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 store_cb - typex - default_ctor - 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 v1_compat - store_cb - typex - default_ctor - 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 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 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 store_cb - static - 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 v1_compat - store_cb - static - 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 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 v1_compat - type - 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 store_cb - type - static - 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 v1_compat - store_cb - type - static - 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 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 v1_compat - typex - 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 store_cb - typex - static - 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 v1_compat - store_cb - typex - static - 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_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 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 store_cb - default_ctor - static - 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 v1_compat - store_cb - default_ctor - static - 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 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 - type - 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 store_cb - type - default_ctor - static - 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 - store_cb - type - default_ctor - static - 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 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 v1_compat - typex - 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 store_cb - typex - default_ctor - static - 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 v1_compat - store_cb - typex - default_ctor - static - 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 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 v1_compat - default - 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 store_cb - default - 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 v1_compat - store_cb - default - 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 type - default - 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 - type - default - 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 store_cb - type - default - 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 - type - default - 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 typex - default - 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 v1_compat - typex - default - 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 store_cb - typex - default - 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 v1_compat - store_cb - typex - default - 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 static - default - 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 v1_compat - static - default - 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 store_cb - static - default - 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 v1_compat - store_cb - static - default - 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 type - static - default - 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 - type - static - default - 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 store_cb - type - static - default - 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 - store_cb - type - static - default - 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 typex - static - default - 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 v1_compat - typex - static - default - 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 store_cb - typex - static - default - 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 v1_compat - store_cb - typex - static - default - 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 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 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 store_cb - read_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 v1_compat - store_cb - read_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 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 v1_compat - type - 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 store_cb - type - read_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 v1_compat - store_cb - type - read_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 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 v1_compat - typex - 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 store_cb - typex - read_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 v1_compat - store_cb - typex - read_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_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 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 store_cb - default_ctor - read_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 v1_compat - store_cb - default_ctor - read_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 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 - type - 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 store_cb - type - default_ctor - read_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 - store_cb - type - default_ctor - read_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 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 v1_compat - typex - 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 store_cb - typex - default_ctor - read_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 v1_compat - store_cb - typex - default_ctor - read_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 static - read_cb - 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 v1_compat - static - read_cb - 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 store_cb - static - read_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 v1_compat - store_cb - static - read_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 type - static - read_cb - 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 v1_compat - type - static - read_cb - 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 store_cb - type - static - read_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 v1_compat - store_cb - type - static - read_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 typex - static - read_cb - 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 v1_compat - typex - static - read_cb - 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 store_cb - typex - static - read_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 v1_compat - store_cb - typex - static - read_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_ctor - static - read_cb - 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 v1_compat - default_ctor - static - read_cb - 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 store_cb - default_ctor - static - read_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 v1_compat - store_cb - default_ctor - static - read_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 type - default_ctor - static - read_cb - 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 - type - default_ctor - static - read_cb - 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 - type - default_ctor - static - read_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 - store_cb - type - default_ctor - static - read_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; } #------------------ # scalar typex - default_ctor - static - read_cb - 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 v1_compat - typex - default_ctor - static - read_cb - 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 store_cb - typex - default_ctor - static - read_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 v1_compat - store_cb - typex - default_ctor - static - read_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 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 v1_compat - default - 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 store_cb - default - read_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 v1_compat - store_cb - default - read_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 type - default - 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 - type - default - 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 store_cb - type - default - read_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 - store_cb - type - default - read_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 typex - default - 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 v1_compat - typex - default - 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 store_cb - typex - default - read_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 v1_compat - store_cb - typex - default - read_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 static - default - read_cb - 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 v1_compat - static - default - read_cb - 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 store_cb - static - default - read_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 v1_compat - store_cb - static - default - read_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 type - static - default - read_cb - 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 - type - static - default - read_cb - 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 store_cb - type - static - default - read_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 - store_cb - type - static - default - read_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 typex - static - default - read_cb - 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 v1_compat - typex - static - default - read_cb - 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 store_cb - typex - static - default - read_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 v1_compat - store_cb - typex - static - default - read_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; } #------------------------------------ 1; # keep require happy