From e528b6072f9f5a668f9b01d9ab00c92a31d12e64 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Tue, 17 May 2011 22:40:34 +0100 Subject: [PATCH] Update Object-Accessor to CPAN version 0.42 [DELTA] Changes for 0.42 Fri May 13 12:21:50 BST 2011 ================================================= * Missed a test using exists, Ikegami RT #68154 Changes for 0.40 Thu May 12 20:41:36 BST 2011 ================================================= * Apply patch from Ikegami RT #68154, which avoids use of deprecated exists on array elements. --- Porting/Maintainers.pl | 2 +- cpan/Object-Accessor/lib/Object/Accessor.pm | 172 ++++++++++----------- .../t/01_Object-Accessor-Subclassed.t | 16 +- cpan/Object-Accessor/t/02_Object-Accessor-allow.t | 12 +- cpan/Object-Accessor/t/03_Object-Accessor-local.t | 6 +- cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t | 16 +- .../t/05_Object-Accessor-callback.t | 18 +-- 7 files changed, 121 insertions(+), 121 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 373c04e..bd38a86 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1352,7 +1352,7 @@ use File::Glob qw(:case); 'Object::Accessor' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/Object-Accessor-0.38.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Object-Accessor-0.42.tar.gz', 'FILES' => q[cpan/Object-Accessor], 'UPSTREAM' => 'cpan', }, diff --git a/cpan/Object-Accessor/lib/Object/Accessor.pm b/cpan/Object-Accessor/lib/Object/Accessor.pm index c7933ec..edee181 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 are passed straight to C. If you want to be able to assign to your accessors as if they -were Cs, you should create your object in the +were Cs, you should create your object in the C namespace instead. See the section on C below. @@ -126,9 +126,9 @@ on C 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 for details. Note that you can bind the values of attributes to a scope. This allows -you to C change a value of an attribute, and have it's +you to C 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 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 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 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 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 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! General usage for +Use only if you C! 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! General usage for +Use only if you C! 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! +Use only if you C! =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. 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 class. @@ -685,7 +685,7 @@ See C for details. Due to the nature of C, 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 and a C call. Callbacks are therefor unsupported +a C and a C call. Callbacks are therefor unsupported under C conditions. See C for details. @@ -702,7 +702,7 @@ See C 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 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 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. -Due to a bug in storable (until at least version 2.15), C 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 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 Ekane@cpan.orgE. =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 8ebe7f1..29823e9 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 396ef2b..53ddf62 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 ''" ); 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 f085683..1a9b070 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 092c741..6eb45b3 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 5411bbd..a2bbb17 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 " ); 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 " ); + " Direct get returns " ); ok( $Called, " Callback called" ); - + #diag("Running SET tests on regular objects"); $Called = 0; ok( $clone->$Acc($SetVal), " Setting $Acc" ); -- 2.7.4