# (X)Emacs mode: -*- cperl -*-
# This file is preprocessed by cmmg.pl . Subs are sought, as 'sub name {' (at
# a line begin) until '}' at a line begin. Optional POD documentation may
# precede, if started with =head (and ended with =cut). Blank lines &
# comments in between will be silently ignored, and anything else will be
# noisily ignored.
# -------------------------------------
=head1 NAME
Class::Method::scalar - Create methods for handling a scalar value.
=head1 SYNOPSIS
package MyClass;
use Class::MethodMaker
[ scalar => [qw/ a -static s /]];
sub new {
my $class = shift;
bless {}, $class;
}
package main;
my $m = MyClass->new;
my $a, $x;
$a = $m->a; # *undef*
$x = $m->a_isset; # false
$a = $m->a(1); # 1
$m->a(3);
$x = $m->a_isset; # true
$a = $m->a; # 3
$a = $m->a(5); # 5;
$m->a_reset;
$x = $m->a_isset; # false
=head1 DESCRIPTION
Creates methods to handle array values in an object. For a component named
C<x>, by default creates methods C<x>, C<x_reset>, C<x_isset>, C<x_clear>.
=cut
sub scalar {
my $class = shift;
my ($target_class, $name, $options, $global) = @_;
# options check ---------------------
Class::MethodMaker::Engine::check_opts([qw/ static type typex forward
default default_ctor
read_cb store_cb
tie_class tie_args
key_create
v1_compat v1_object
_value_list
/], $options);
# type option
my $type = $options->{type};
croak "argument to -type ($type) must be a simple value\n"
unless ! ref $type;
# forward option
my $forward = $options->{forward};
my @forward;
if ( defined $forward ) {
if ( ref $forward ) {
croak("-forward option can only handle arrayrefs or simple values " .
"($forward)\n")
unless UNIVERSAL::isa($forward, 'ARRAY');
@forward = @$forward;
print "Value '$_' passed to -forward is not a simple value"
for grep ref($_), @forward;
} else {
@forward = $forward;
}
}
# default options
my ($default, $dctor, $default_defined, $v1object);
if ( exists $options->{default} ) {
croak("Cannot specify both default & default_ctor options to scalar ",
"(attribute $name\n")
if exists $options->{default_ctor};
$default = $options->{default};
$default_defined = 1;
} elsif ( exists $options->{default_ctor} ) {
if ( ! ref $options->{default_ctor} ) {
my $meth = $options->{default_ctor};
croak("default_ctor can only be a simple value when -type is in effect",
" (attribute $name)\n")
unless defined $type;
croak("default_ctor must be a valid identifier (or a code ref): $meth ",
"(attribute $name)\n")
unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
$dctor = sub { $type->$meth(@_) };
$v1object = $options->{v1_object}
if $options->{v1_compat};
} else {
$dctor = $options->{default_ctor};
croak(sprintf( "Argument to default_ctor must be a simple value or a code ref " .
" (attribute $name) (got '%s')\n", ref $dctor ) )
if ! UNIVERSAL::isa($dctor, 'CODE');
}
$default_defined = 1;
}
# tie options
my ($tie_class, @tie_args);
if ( exists $options->{tie_class} ) {
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
%%STORDECL%%
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * );
=pod
Methods available are:
=cut
my %methods =
=pod
=head3 C<*>
$m->a(3);
$a = $m->a; # 3
$a = $m->a(5); # 5;
I<Created by default>. If an argument is provided, the component is set to
that value. The method returns the value of the component (after assignment
to a provided value, if appropriate).
=cut
( '*' => sub : method {
if ( @_ == 1 ) {
%%V1COMPAT_ON%%
if ( $v1object and ! exists $_[0]->{$name} ) {
%%STORAGE%% = $dctor->();
}
%%V1COMPAT_OFF%%
%%DEFCHECK$%%
%%READ0(%%STORAGE%%)%%
} else {
%%STORE($_[1],$v)%% %%V2ONLY%%
%%V1COMPAT_ON%%
%%STORE($_[1],$v,@_[1..$#_])%%
unless ( $v1object ) {
%%ASGNCHK$(%%IFSTORE($v,$_[1])%%)%%
}
%%V1COMPAT_OFF%%
%%ASGNCHK$(%%IFSTORE($v,$_[1])%%)%% %%V2ONLY%%
%%STORAGE%% = %%IFSTORE($v,$_[1])%%; %%V2ONLY%%
%%V1COMPAT_ON%%
if ( $v1object ) {
if ( ref $_[1] and UNIVERSAL::isa($_[1], $type) ) {
%%STORAGE%% = $_[1];
} else {
%%STORAGE%% = $dctor->(@_[1..$#_]);
}
} else {
%%STORAGE%% = %%IFSTORE($v,$_[1])%%
}
%%V1COMPAT_OFF%%
%%READ1(%%STORAGE%%)%%
}
},
=pod
=head3 C<*_reset>
$m->a_reset;
I<Created by default>. Resets the component back to its default. Normally,
this means that C<*_isset> will return false, and C<*> will return undef. If
C<-default> is in effect, then the component will be set to the default value,
and C<*_isset> will return true. If C<-default_ctor> is in effect, then the
default subr will be invoked, and its return value used to set the value of
the component, and C<*_isset> will return true.
B<Advanced Note>: actually, defaults are assigned as needed: typically, the
next time a the value of a component is read.
=cut
'*_reset' => sub : method {
delete %%STORAGE%%;
},
=pod
=head3 C<*_isset>
print $m->a_isset ? "true" : "false";
I<Created by default>. Whether the component is currently set. This is
different from being defined; initially, the component is not set (and if
read, will return undef); it can be set to undef (which is a set value, which
also returns undef). Having been set, the only way to unset the component is
with <*_reset>.
If a default value is in effect, then <*_isset> will always return true.
=cut
'*_isset' => ( $default_defined ?
sub : method { 1 } :
sub : method {
exists %%STORAGE%%;
}
),
=pod
=head3 C<*_clear>
$m->a(5);
$a = $m->a; # 5
$x = $m->a_isset; # true
$m->a_clear;
$a = $m->a; # *undef*
$x = $m->a_isset; # true
I<Created by default>. A shorthand for setting to undef. Note that the
component will be set to undef, not reset, so C<*_isset> will return true.
=cut
'*_clear' => sub : method {
my $x = $names{'*'};
$_[0]->$x(undef);
},
=pod
=head3 C<*_get>
package MyClass;
use Class::MethodMaker
[ scalar => [{'*_get' => '*_get'}, 'a'],
new => new, ];
package main;
my $m = MyClass->new;
$m->a(3);
$a = $m->a_get; # 3
$a = $m->a_get(5); # 3; ignores argument
$a = $m->a_get(5); # 3; unchanged by previous call
I<Created on request>. Retrieves the value of the component without setting
(ignores any arguments passed).
=cut
'!*_get' => sub : method {
my $x = $names{'*'};
return $_[0]->$x();
},
=pod
=head3 C<*_set>
package MyClass;
use Class::MethodMaker
[ scalar => [{'*_set' => '*_set'}, 'a'],
new => new, ];
package main;
my $m = MyClass->new;
$m->a(3);
$a = $m->a_set; # *undef*
$a = $m->a_set(5); # *undef*; value is set but not returned
$a = $m->a; # 5
I<Created on request>. Sets the component to the first argument (or undef if
no argument provided). Returns no value.
=cut
'!*_set' => sub : method {
my $x = $names{'*'};
$_[0]->$x($_[1]);
return;
},
# this is here for V1 compatiblity only
'!*_find' => sub : method {
my ($self, @args) = @_;
if (scalar @args) {
if ( $key_create ) {
$self->new->$name($_)
for grep ! exists $list->{$_}, @args;
}
return @{$list}{@args};
} else {
return $list;
}
},
%%IMPORT(CommonMethods)%%
# forward methods
map({; my $f = $_;
$_ =>
sub : method {
my $x = $names{'*'};
$_[0]->$x()->$f(@_[1..$#_]);
}
} @forward),
);
return \%methods, \%names;
}