From: Steve Peters Date: Wed, 21 May 2008 13:16:58 +0000 (+0000) Subject: Upgrade to Object-Accessor-0.34 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1eea129cabc5a7602cbb7079da41a713264d28bf;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Object-Accessor-0.34 p4raw-id: //depot/perl@33899 --- diff --git a/MANIFEST b/MANIFEST index 8ebcd17..debd070 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2331,6 +2331,7 @@ lib/Object/Accessor/t/02_Object-Accessor-allow.t Object::Accessor tests lib/Object/Accessor/t/03_Object-Accessor-local.t Object::Accessor tests lib/Object/Accessor/t/04_Object-Accessor-lvalue.t Object::Accessor tests lib/Object/Accessor/t/05_Object-Accessor-callback.t Object::Accessor tests +lib/Object/Accessor/t/06_Object-Accessor-alias.t Object::Accessor tests lib/open2.pl Open a two-ended pipe (uses IPC::Open2) lib/open3.pl Open a three-ended pipe (uses IPC::Open3) lib/open.pm Pragma to specify default I/O layers diff --git a/lib/Object/Accessor.pm b/lib/Object/Accessor.pm index dda006a..e5cd266 100644 --- a/lib/Object/Accessor.pm +++ b/lib/Object/Accessor.pm @@ -10,12 +10,13 @@ use Data::Dumper; ### disable string overloading for callbacks require overload; -$VERSION = '0.32'; +$VERSION = '0.34'; $FATAL = 0; $DEBUG = 0; use constant VALUE => 0; # array index in the hash value use constant ALLOW => 1; # array index in the hash value +use constant ALIAS => 2; # array index in the hash value =head1 NAME @@ -32,6 +33,9 @@ Object::Accessor $bool = $obj->mk_accessors('foo'); # create accessors $bool = $obj->mk_accessors( # create accessors with input {foo => ALLOW_HANDLER} ); # validation + + $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 @@ -240,6 +244,42 @@ sub ls_allow { : sub { 1 }; } +=head2 $bool = $self->mk_aliases( alias => method, [alias2 => method2, ...] ); + +Creates an alias for a given method name. For all intents and purposes, +these two accessors are now identical for this object. This is akin to +doing the following on the symbol table level: + + *alias = *method + +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 + +=cut + +sub mk_aliases { + my $self = shift; + my %aliases = @_; + + while( my($alias, $method) = each %aliases ) { + + ### already created apparently + if( exists $self->{$alias} ) { + __PACKAGE__->___debug( "Accessor '$alias' already exists"); + next; + } + + $self->___alias( $alias => $method ); + } + + return 1; +} + =head2 $clone = $self->mk_clone; Makes a clone of the current object, which will have the exact same @@ -257,11 +297,16 @@ sub mk_clone { ### split out accessors with and without allow handlers, so we ### don't install dummy allow handers (which makes O::A::lvalue - ### warn for exampel) + ### warn for example) my %hash; my @list; for my $acc ( $self->ls_accessors ) { my $allow = $self->{$acc}->[ALLOW]; $allow ? $hash{$acc} = $allow : push @list, $acc; + + ### is this an alias? + if( my $org = $self->{ $acc }->[ ALIAS ] ) { + $clone->___alias( $acc => $org ); + } } ### copy the accessors from $self to $clone @@ -436,6 +481,11 @@ sub ___autoload { "'$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 ); @@ -537,6 +587,25 @@ sub ___set { return 1; } +=head2 $bool = $self->___alias( ALIAS => METHOD ); + +Method to directly alias one accessor to another for +this object. It circumvents all sanity checks, etc. + +Use only if you C! + +=cut + +sub ___alias { + my $self = shift; + my $alias = shift or return; + my $method = shift or return; + + $self->{ $alias }->[ALIAS] = $method; + + return 1; +} + sub ___debug { return unless $DEBUG; @@ -697,6 +766,8 @@ See C for details. } } +=back + =head1 GLOBAL VARIABLES =head2 $Object::Accessor::FATAL @@ -730,20 +801,18 @@ You can track the bug here: http://rt.cpan.org/Ticket/Display.html?id=1827 +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-object-accessor@rt.cpan.orgE. + =head1 AUTHOR -This module by -Jos Boumans Ekane@cpan.orgE. +This module by Jos Boumans Ekane@cpan.orgE. =head1 COPYRIGHT -This module is -copyright (c) 2004-2005 Jos Boumans Ekane@cpan.orgE. -All rights reserved. - -This library is free software; -you may redistribute and/or modify it under the same -terms as Perl itself. +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. =cut diff --git a/lib/Object/Accessor/t/06_Object-Accessor-alias.t b/lib/Object/Accessor/t/06_Object-Accessor-alias.t new file mode 100644 index 0000000..2a8aa81 --- /dev/null +++ b/lib/Object/Accessor/t/06_Object-Accessor-alias.t @@ -0,0 +1,33 @@ +BEGIN { chdir 't' if -d 't' }; + +use strict; +use lib '../lib'; +use Test::More 'no_plan'; +use Data::Dumper; + +my $Class = 'Object::Accessor'; + +use_ok($Class); + +my $Object = $Class->new; +my $Acc = 'foo'; +my $Alias = 'bar'; + +### basic sanity test +{ ok( $Object, "Object created" ); + + ok( $Object->mk_accessors( $Acc ), + " Accessor ->$Acc created" ); + ok( $Object->$Acc( $$ ), " ->$Acc set to $$" ); +} + +### alias tests +{ ok( $Object->mk_aliases( $Alias => $Acc ), + "Alias ->$Alias => ->$Acc" ); + ok( $Object->$Alias, " ->$Alias returns value" ); + is( $Object->$Acc, $Object->$Alias, + " ->$Alias eq ->$Acc" ); + ok( $Object->$Alias( $0 ), " Set value via alias ->$Alias" ); + is( $Object->$Acc, $Object->$Alias, + " ->$Alias eq ->$Acc" ); +}