### disable string overloading for callbacks
require overload;
-$VERSION = '0.38';
+$VERSION = '0.42';
$FATAL = 0;
$DEBUG = 0;
$bool = $obj->mk_aliases( # create an alias to an existing
alias_name => 'method'); # method name
-
+
$clone = $obj->mk_clone; # create a clone of original
# object without data
$bool = $obj->mk_flush; # clean out all data
### advanced usage -- callbacks
{ my $obj = Object::Accessor->new('foo');
$obj->register_callback( sub { ... } );
-
+
$obj->foo( 1 ); # these calls invoke the callback you registered
- $obj->foo() # which allows you to change the get/set
+ $obj->foo() # which allows you to change the get/set
# behaviour and what is returned to the caller.
- }
+ }
### advanced usage -- lvalue attributes
{ my $obj = Object::Accessor::Lvalue->new('foo');
### advanced usage -- scoped attribute values
{ my $obj = Object::Accessor->new('foo');
-
+
$obj->foo( 1 );
print $obj->foo; # will print 1
### bind the scope of the value of attribute 'foo'
- ### to the scope of '$x' -- when $x goes out of
+ ### to the scope of '$x' -- when $x goes out of
### scope, 'foo's previous value will be restored
{ $obj->foo( 2 => \my $x );
print $obj->foo, ' ', $x; # will print '2 2'
Any arguments given to C<new> are passed straight to C<mk_accessors>.
If you want to be able to assign to your accessors as if they
-were C<lvalue>s, you should create your object in the
+were C<lvalue>s, you should create your object in the
C<Object::Accessor::Lvalue> namespace instead. See the section
on C<LVALUE ACCESSORS> below.
sub new {
my $class = shift;
my $obj = bless {}, $class;
-
+
$obj->mk_accessors( @_ ) if @_;
-
+
return $obj;
}
foo => qr/^\d+$/, # digits only
bar => [0,1], # booleans
zot => \&my_sub # a custom verification sub
- } );
+ } );
Returns true on success, false on failure.
VARIABLES> for details.
Note that you can bind the values of attributes to a scope. This allows
-you to C<temporarily> change a value of an attribute, and have it's
+you to C<temporarily> change a value of an attribute, and have it's
original value restored up on the end of it's bound variable's scope;
-For example, in this snippet of code, the attribute C<foo> will
-temporarily be set to C<2>, until the end of the scope of C<$x>, at
+For example, in this snippet of code, the attribute C<foo> will
+temporarily be set to C<2>, until the end of the scope of C<$x>, at
which point the original value of C<1> will be restored.
my $obj = Object::Accessor->new;
-
+
$obj->mk_accessors('foo');
$obj->foo( 1 );
print $obj->foo; # will print 1
### bind the scope of the value of attribute 'foo'
- ### to the scope of '$x' -- when $x goes out of
+ ### to the scope of '$x' -- when $x goes out of
### scope, 'foo' previous value will be restored
{ $obj->foo( 2 => \my $x );
print $obj->foo, ' ', $x; # will print '2 2'
}
print $obj->foo; # will print 1
-
+
Note that all accessors are read/write for everyone. See the C<TODO>
section for details.
sub mk_accessors {
my $self = $_[0];
my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' );
-
+
### first argument is a hashref, which means key/val pairs
### as keys + allow handlers
for my $acc ( $is_hash ? keys %{$_[1]} : @_[1..$#_] ) {
-
+
### already created apparently
if( exists $self->{$acc} ) {
__PACKAGE__->___debug( "Accessor '$acc' already exists");
### explicitly vivify it, so that exists works in ls_accessors()
$self->{$acc}->[VALUE] = undef;
-
+
### set the allow handler only if one was specified
$self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash;
}
=cut
sub ls_accessors {
- ### metainformation is stored in the stringified
+ ### metainformation is stored in the stringified
### key of the object, so skip that when listing accessors
return sort grep { $_ ne "$_[0]" } keys %{$_[0]};
}
my $self = shift;
my $key = shift or return;
return exists $self->{$key}->[ALLOW]
- ? $self->{$key}->[ALLOW]
+ ? $self->{$key}->[ALLOW]
: sub { 1 };
}
$self->mk_accessors('foo');
$self->mk_aliases( bar => 'foo' );
-
+
$self->bar( 42 );
print $self->foo; # will print 42
sub mk_aliases {
my $self = shift;
my %aliases = @_;
-
+
while( my($alias, $method) = each %aliases ) {
### already created apparently
my $class = ref $self;
my $clone = $class->new;
-
+
### split out accessors with and without allow handlers, so we
### don't install dummy allow handers (which makes O::A::lvalue
### warn for example)
sub mk_verify {
my $self = $_[0];
-
+
my $fail;
for my $name ( $self->ls_accessors ) {
unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
return if $fail;
return 1;
-}
+}
=head2 $bool = $self->register_callback( sub { ... } );
data is even stored in the object.
Below is an example of the use of a callback.
-
+
$object->some_method( "some_value" );
-
+
my $callback = sub {
my $self = shift; # the object
my $meth = shift; # "some_method"
- my $val = shift; # ["some_value"]
+ my $val = shift; # ["some_value"]
# could be undef -- check 'exists';
# if scalar @$val is empty, it was a 'get'
-
+
# your code here
return $new_val; # the value you want to be set/returned
- }
+ }
To access the values stored in the object, circumventing the
callback structure, you should use the C<___get> and C<___set> methods
-documented further down.
+documented further down.
=cut
sub register_callback {
my $self = shift;
my $sub = shift or return;
-
+
### use the memory address as key, it's not used EVER as an
### accessor --kane
$self->___callback( $sub );
if ( not exists $self->{$method} ) {
__PACKAGE__->___error("No such accessor '$method'", 1);
return;
- }
-
+ }
+
### a method on something else, die with a descriptive error;
- } else {
+ } else {
local $FATAL = 1;
- __PACKAGE__->___error(
+ __PACKAGE__->___error(
"You called '$AUTOLOAD' on '$self' which was interpreted by ".
__PACKAGE__ . " as an object call. Did you mean to include ".
"'$method' from somewhere else?", 1 );
- }
+ }
### is this is an alias, redispatch to the original method
if( my $original = $self->{ $method }->[ALIAS] ) {
return $self->___autoload( $original, @_ );
- }
+ }
### assign?
my $val = $assign ? shift(@_) : $self->___get( $method );
### any binding?
if( $_[0] ) {
if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
-
+
### tie the reference, so we get an object and
### we can use it's going out of scope to restore
### the old value
my $cur = $self->{$method}->[VALUE];
-
- tie ${$_[0]}, __PACKAGE__ . '::TIE',
+
+ tie ${$_[0]}, __PACKAGE__ . '::TIE',
sub { $self->$method( $cur ) };
-
+
${$_[0]} = $val;
-
+
} else {
- __PACKAGE__->___error(
- "Can not bind '$method' to anything but a SCALAR", 1
+ __PACKAGE__->___error(
+ "Can not bind '$method' to anything but a SCALAR", 1
);
}
}
-
+
### need to check the value?
- if( exists $self->{$method}->[ALLOW] ) {
+ if( defined $self->{$method}->[ALLOW] ) {
### double assignment due to 'used only once' warnings
local $Params::Check::VERBOSE = 0;
local $Params::Check::VERBOSE = 0;
-
+
allow( $val, $self->{$method}->[ALLOW] ) or (
- __PACKAGE__->___error(
- "'$val' is an invalid value for '$method'", 1),
- return
- );
+ __PACKAGE__->___error(
+ "'$val' is an invalid value for '$method'", 1),
+ return
+ );
}
}
-
+
### callbacks?
if( my $sub = $self->___callback ) {
$val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
-
+
### register the error
$self->___error( $@, 1 ), return if $@;
}
if( $assign ) {
$self->___set( $method, $val ) or return;
}
-
+
return [$val];
}
Method to directly access the value of the given accessor in the
object. It circumvents all calls to allow checks, callbacks, etc.
-Use only if you C<Know What You Are Doing>! General usage for
+Use only if you C<Know What You Are Doing>! General usage for
this functionality would be in your own custom callbacks.
=cut
Method to directly set the value of the given accessor in the
object. It circumvents all calls to allow checks, callbacks, etc.
-Use only if you C<Know What You Are Doing>! General usage for
+Use only if you C<Know What You Are Doing>! General usage for
this functionality would be in your own custom callbacks.
-=cut
+=cut
sub ___set {
my $self = shift;
my $method = shift or return;
-
+
### you didn't give us a value to set!
- exists $_[0] or return;
+ @_ or return;
my $val = shift;
-
+
### if there's more arguments than $self, then
### replace the method called by the accessor.
### XXX implement rw vs ro accessors!
Method to directly alias one accessor to another for
this object. It circumvents all sanity checks, etc.
-Use only if you C<Know What You Are Doing>!
+Use only if you C<Know What You Are Doing>!
=cut
my $self = shift;
my $alias = shift or return;
my $method = shift or return;
-
+
$self->{ $alias }->[ALIAS] = $method;
-
+
return 1;
}
my $lvl = shift || 0;
local $Carp::CarpLevel += 1;
-
+
carp($msg);
}
sub ___callback {
my $self = shift;
my $sub = shift;
-
+
my $mem = overload::Overloaded( $self )
? overload::StrVal( $self )
: "$self";
$self->{$mem} = $sub if $sub;
-
+
return $self->{$mem};
}
my $obj = Object::Accessor::Lvalue->new('foo');
$obj->foo += 1;
print $obj->foo;
-
+
will actually print C<1> and work as expected. Since this is an
optional feature, that's not desirable in all cases, we require
you to explicitly use the C<Object::Accessor::Lvalue> class.
Due to the nature of C<lvalue subs>, we never get access to the
value you are assigning, so we can not check provide this value
to your callback. Furthermore, we can not distinguish between
-a C<get> and a C<set> call. Callbacks are therefor unsupported
+a C<get> and a C<set> call. Callbacks are therefor unsupported
under C<lvalue> conditions.
See C<perldoc perlsub> for details.
*VALUE = *Object::Accessor::VALUE;
*ALLOW = *Object::Accessor::ALLOW;
- ### largely copied from O::A::Autoload
+ ### largely copied from O::A::Autoload
sub AUTOLOAD : lvalue {
my $self = shift;
my($method) = ($AUTOLOAD =~ /([^:']+$)/);
sub mk_accessors {
my $self = shift;
my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
-
+
$self->___error(
"Allow handlers are not supported for '". __PACKAGE__ ."' objects"
) if $is_hash;
-
+
return $self->SUPER::mk_accessors( @_ );
- }
-
+ }
+
sub register_callback {
my $self = shift;
$self->___error(
"Callbacks are not supported for '". __PACKAGE__ ."' objects"
);
return;
- }
-}
+ }
+}
### standard tie class for bound attributes
my $ref = undef;
my $obj = bless \$ref, $class;
- ### store the restore sub
+ ### store the restore sub
$local{ $obj } = $sub;
return $obj;
}
-
+
sub DESTROY {
my $tied = shift;
my $sub = delete $local{ $tied };
### run the restore sub to set the old value back
- return $sub->();
- }
+ return $sub->();
+ }
}
=back
If you use codereferences for your allow handlers, you will not be able
to freeze the data structures using C<Storable>.
-Due to a bug in storable (until at least version 2.15), C<qr//> compiled
-regexes also don't de-serialize properly. Although this bug has been
+Due to a bug in storable (until at least version 2.15), C<qr//> compiled
+regexes also don't de-serialize properly. Although this bug has been
reported, you should be aware of this issue when serializing your objects.
-You can track the bug here:
+You can track the bug here:
http://rt.cpan.org/Ticket/Display.html?id=1827
=head1 COPYRIGHT
-This library is free software; you may redistribute and/or modify it
+This library is free software; you may redistribute and/or modify it
under the same terms as Perl itself.
=cut
projects / platform / upstream / perl.git / commitdiff