diff options
Diffstat (limited to 'cpan/Object-Accessor')
| -rw-r--r-- | cpan/Object-Accessor/lib/Object/Accessor.pm | 172 | ||||
| -rw-r--r-- | cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t | 16 | ||||
| -rw-r--r-- | cpan/Object-Accessor/t/02_Object-Accessor-allow.t | 12 | ||||
| -rw-r--r-- | cpan/Object-Accessor/t/03_Object-Accessor-local.t | 6 | ||||
| -rw-r--r-- | cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t | 16 | ||||
| -rw-r--r-- | cpan/Object-Accessor/t/05_Object-Accessor-callback.t | 18 |
6 files changed, 120 insertions, 120 deletions
diff --git a/cpan/Object-Accessor/lib/Object/Accessor.pm b/cpan/Object-Accessor/lib/Object/Accessor.pm index c7933ec866..edee181d07 100644 --- a/cpan/Object-Accessor/lib/Object/Accessor.pm +++ b/cpan/Object-Accessor/lib/Object/Accessor.pm @@ -10,7 +10,7 @@ use Data::Dumper; ### disable string overloading for callbacks require overload; -$VERSION = '0.38'; +$VERSION = '0.42'; $FATAL = 0; $DEBUG = 0; @@ -36,7 +36,7 @@ Object::Accessor - interface to create per object accessors $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 @@ -69,11 +69,11 @@ Object::Accessor - interface to create per object accessors ### 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'); @@ -82,12 +82,12 @@ Object::Accessor - interface to create per object accessors ### 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' @@ -117,7 +117,7 @@ inheritable. 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. @@ -126,9 +126,9 @@ on C<LVALUE ACCESSORS> below. sub new { my $class = shift; my $obj = bless {}, $class; - + $obj->mk_accessors( @_ ) if @_; - + return $obj; } @@ -151,7 +151,7 @@ For example: foo => qr/^\d+$/, # digits only bar => [0,1], # booleans zot => \&my_sub # a custom verification sub - } ); + } ); Returns true on success, false on failure. @@ -161,27 +161,27 @@ global variable C<$FATAL> to true. See the section on C<GLOBAL 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. @@ -191,11 +191,11 @@ 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"); @@ -206,7 +206,7 @@ sub mk_accessors { ### 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; } @@ -223,7 +223,7 @@ by one to the C<can> method. =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]}; } @@ -240,7 +240,7 @@ sub ls_allow { my $self = shift; my $key = shift or return; return exists $self->{$key}->[ALLOW] - ? $self->{$key}->[ALLOW] + ? $self->{$key}->[ALLOW] : sub { 1 }; } @@ -256,7 +256,7 @@ This allows you to do the following: $self->mk_accessors('foo'); $self->mk_aliases( bar => 'foo' ); - + $self->bar( 42 ); print $self->foo; # will print 42 @@ -265,7 +265,7 @@ This allows you to do the following: sub mk_aliases { my $self = shift; my %aliases = @_; - + while( my($alias, $method) = each %aliases ) { ### already created apparently @@ -294,7 +294,7 @@ sub mk_clone { 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) @@ -348,7 +348,7 @@ object has been filled with values satisfying their own allow criteria. sub mk_verify { my $self = $_[0]; - + my $fail; for my $name ( $self->ls_accessors ) { unless( allow( $self->$name, $self->ls_allow( $name ) ) ) { @@ -361,7 +361,7 @@ sub mk_verify { return if $fail; return 1; -} +} =head2 $bool = $self->register_callback( sub { ... } ); @@ -373,31 +373,31 @@ You are free to return whatever you wish. On a C<set> call, the 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 ); @@ -470,21 +470,21 @@ sub ___autoload { 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 ); @@ -494,43 +494,43 @@ sub ___autoload { ### 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 $@; } @@ -539,7 +539,7 @@ sub ___autoload { if( $assign ) { $self->___set( $method, $val ) or return; } - + return [$val]; } @@ -548,7 +548,7 @@ sub ___autoload { 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 @@ -566,19 +566,19 @@ sub ___get { 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! @@ -592,7 +592,7 @@ sub ___set { 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 @@ -600,9 +600,9 @@ sub ___alias { my $self = shift; my $alias = shift or return; my $method = shift or return; - + $self->{ $alias }->[ALIAS] = $method; - + return 1; } @@ -614,7 +614,7 @@ sub ___debug { my $lvl = shift || 0; local $Carp::CarpLevel += 1; - + carp($msg); } @@ -632,13 +632,13 @@ sub ___error { 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}; } @@ -651,7 +651,7 @@ C<Object::Accessor::Lvalue>. For example: 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. @@ -685,7 +685,7 @@ See C<perldoc perlsub> for details. 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. @@ -702,7 +702,7 @@ 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 =~ /([^:']+$)/); @@ -720,22 +720,22 @@ See C<perldoc perlsub> for details. 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 @@ -752,18 +752,18 @@ See C<perldoc perlsub> for details. 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 @@ -793,11 +793,11 @@ release should make it possible to have read-only accessors as well. 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 @@ -811,7 +811,7 @@ This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. =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 diff --git a/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t b/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t index 8ebe7f1343..29823e962e 100644 --- a/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t +++ b/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t @@ -14,7 +14,7 @@ use_ok($Class); ### establish another package that subclasses our own { package My::Class; use base 'Object::Accessor'; -} +} my $Object = $MyClass->new; @@ -22,24 +22,24 @@ my $Object = $MyClass->new; { ok( $Object, "Object created" ); isa_ok( $Object, $MyClass ); isa_ok( $Object, $Class ); -} +} -### create an accessor +### create an accessor { ok( $Object->mk_accessors( $Acc ), "Accessor '$Acc' created" ); ok( $Object->can( $Acc ), " Object can '$Acc'" ); ok( $Object->$Acc(1), " Objects '$Acc' set" ); ok( $Object->$Acc(), " Objects '$Acc' retrieved" ); -} - +} + ### check if we do the right thing when we call an accessor that's -### not a defined function in the base class, and not an accessors +### not a defined function in the base class, and not an accessors ### in the object either { my $sub = eval { $MyClass->can( $$ ); }; ok( !$sub, "No sub from non-existing function" ); ok( !$@, " Code handled it gracefully" ); -} +} ### check if a method called on a class, that's not actually there ### doesn't get confused as an object call; @@ -48,4 +48,4 @@ my $Object = $MyClass->new; ok( $@, "Calling '$$' on '$MyClass' dies" ); like( $@, qr/from somewhere else/, " Dies with an informative message" ); -} +} diff --git a/cpan/Object-Accessor/t/02_Object-Accessor-allow.t b/cpan/Object-Accessor/t/02_Object-Accessor-allow.t index 396ef2b6f0..53ddf62690 100644 --- a/cpan/Object-Accessor/t/02_Object-Accessor-allow.t +++ b/cpan/Object-Accessor/t/02_Object-Accessor-allow.t @@ -44,15 +44,15 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; { ### bad { my $warning; local $SIG{__WARN__} = sub { $warning .= "@_" }; - + ok( !$Object->$Acc( $0 ), "'$Acc' NOT set to '$0'" ); is( $Object->$Acc(), undef, " '$Acc' still holds '<undef>'" ); like( $warning, $Err_re, " Warnings logged" ); - + ### reset warnings; undef $warning; - - + + my $ok = $Object->mk_verify; ok( !$ok, " Internal verify fails" ); like( $warning, $Ver_re, " Warning logged" ); @@ -63,14 +63,14 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; ### good { my $warning; local $SIG{__WARN__} = sub { $warning .= "@_" }; - + ok( $Object->$Acc( $$ ), "'$Acc' set to '$$'" ); is( $Object->$Acc(), $$, " '$Acc' still holds '$$'" ); ok(!$warning, " No warnings logged" ); ### reset warnings; undef $warning; - + my $ok = $Object->mk_verify; ok( $ok, " Internal verify succeeds" ); ok( !$warning, " No warnings" ); diff --git a/cpan/Object-Accessor/t/03_Object-Accessor-local.t b/cpan/Object-Accessor/t/03_Object-Accessor-local.t index f085683c3a..1a9b070ef6 100644 --- a/cpan/Object-Accessor/t/03_Object-Accessor-local.t +++ b/cpan/Object-Accessor/t/03_Object-Accessor-local.t @@ -40,11 +40,11 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; $Object->$Acc( $$ ); is( $Object->$Acc, $$, " Value set to $$" ); - + ### set it to a scope { $Object->$Acc( $0 => \my $temp ); is( $Object->$Acc, $0, " Value set to $0" ); } - + is( $Object->$Acc, $$, " Value restored to $$" ); -} +} diff --git a/cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t b/cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t index 092c74169a..6eb45b3cb2 100644 --- a/cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t +++ b/cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t @@ -6,10 +6,10 @@ use Data::Dumper; BEGIN { require Test::More; - Test::More->import( + Test::More->import( # silly bbedit [ - $] >= 5.008 - ? 'no_plan' + $] >= 5.008 + ? 'no_plan' : ( skip_all => "Lvalue objects require perl >= 5.8" ) ); } @@ -37,7 +37,7 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; ### create an accessor; { ok( $Object->mk_accessors( $Acc ), "Accessor '$Acc' created" ); - + eval { $Object->$Acc = $$ }; ok( !$@, "lvalue assign successful $@" ); ok( $Object->$Acc, "Accessor '$Acc' set" ); @@ -60,8 +60,8 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; " Got warning about allow handlers" ); } - ok( eval{ $clone->$acc = $$ }, - " Allow handler ignored" ); + ok( eval{ $clone->$acc = $$ }, + " Allow handler ignored" ); ok( ! $@, " No error occurred" ); is( $clone->$acc, $$, " Setting '$acc' worked" ); } @@ -69,7 +69,7 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; ### test registering callbacks { my $clone = $Object->mk_clone; ok( $clone, "Cloned the lvalue object" ); - + { my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; ok( ! $clone->register_callback( sub { } ), @@ -77,6 +77,6 @@ $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; like( $warnings, qr/not supported/, " Got warning about callbacks" ); - } + } } diff --git a/cpan/Object-Accessor/t/05_Object-Accessor-callback.t b/cpan/Object-Accessor/t/05_Object-Accessor-callback.t index 5411bbdd0d..a2bbb170b0 100644 --- a/cpan/Object-Accessor/t/05_Object-Accessor-callback.t +++ b/cpan/Object-Accessor/t/05_Object-Accessor-callback.t @@ -26,18 +26,18 @@ my $Sub = sub { my $obj = shift; my $meth = shift; my $val = shift; - + $Called++; - + ok( 1, " In callback now" ); ok( $obj, " Object received" ); isa_ok( $obj, $Class, " Object"); is( $meth, $Acc, " Method is '$Acc'" ); isa_ok( $val, "ARRAY", " Value" ); - scalar @$val + scalar @$val ? is( $val->[0], $SetVal, " Attempted to set $SetVal" ) - : ok( ! exists $val->[0], + : ok( ! scalar @$val, " This was a GET request" ); return $RetVal; @@ -57,30 +57,30 @@ my $Sub = sub { my $clone = $Object->mk_clone; ok( $clone, "Object cloned" ); - + my $val = $clone->___get($Acc); is( $val, undef, " Direct get returns <undef>" ); ok( $clone->___set( $Acc => $SetVal ), " Direct set is able to set the value" ); is( $clone->___get( $Acc ), $SetVal, " Direct get returns $SetVal" ); - ok( !$Called, " Callbacks didn't get called" ); + ok( !$Called, " Callbacks didn't get called" ); } ### test callbacks on regular objects ### XXX callbacks DO NOT work on lvalue objects. This is verified ### in the lvalue test file, so we dont test here { #diag("Running GET tests on regular objects"); - + my $clone = $Object->mk_clone; $Called = 0; is( $clone->$Acc, $RetVal, " Method '$Acc' returns '$RetVal' " ); is( $clone->___get($Acc), undef, - " Direct get returns <undef>" ); + " Direct get returns <undef>" ); ok( $Called, " Callback called" ); - + #diag("Running SET tests on regular objects"); $Called = 0; ok( $clone->$Acc($SetVal), " Setting $Acc" ); |