Change 33899 by [EMAIL PROTECTED] on 2008/05/21 13:16:58
Upgrade to Object-Accessor-0.34
Affected files ...
... //depot/perl/MANIFEST#1704 edit
... //depot/perl/lib/Object/Accessor.pm#2 edit
... //depot/perl/lib/Object/Accessor/t/06_Object-Accessor-alias.t#1 add
Differences ...
==== //depot/perl/MANIFEST#1704 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1703~33862~ 2008-05-19 05:26:51.000000000 -0700
+++ perl/MANIFEST 2008-05-21 06:16:58.000000000 -0700
@@ -2331,6 +2331,7 @@
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
==== //depot/perl/lib/Object/Accessor.pm#2 (text) ====
Index: perl/lib/Object/Accessor.pm
--- perl/lib/Object/Accessor.pm#1~29113~ 2006-10-26 05:16:49.000000000
-0700
+++ perl/lib/Object/Accessor.pm 2008-05-21 06:16:58.000000000 -0700
@@ -10,12 +10,13 @@
### 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 @@
$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 { 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 @@
### 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 @@
"'$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 @@
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<Know What You Are Doing>!
+
+=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 @@
}
}
+=back
+
=head1 GLOBAL VARIABLES
=head2 $Object::Accessor::FATAL
@@ -730,20 +801,18 @@
http://rt.cpan.org/Ticket/Display.html?id=1827
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>[EMAIL PROTECTED]<gt>.
+
=head1 AUTHOR
-This module by
-Jos Boumans E<lt>[EMAIL PROTECTED]<gt>.
+This module by Jos Boumans E<lt>[EMAIL PROTECTED]<gt>.
=head1 COPYRIGHT
-This module is
-copyright (c) 2004-2005 Jos Boumans E<lt>[EMAIL PROTECTED]<gt>.
-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
==== //depot/perl/lib/Object/Accessor/t/06_Object-Accessor-alias.t#1 (text) ====
Index: perl/lib/Object/Accessor/t/06_Object-Accessor-alias.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/Object/Accessor/t/06_Object-Accessor-alias.t 2008-05-21
06:16:58.000000000 -0700
@@ -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" );
+}
End of Patch.
