diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-09-26 15:49:46 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-09-26 17:51:17 +0100 |
commit | 71e9501eb5f515e4c2f2e89dacb9f682c4e7fb0f (patch) | |
tree | 924190fac97e8523a8a8dcdde7705ae296bc0271 /cpan/Object-Accessor | |
parent | f436ffb1e59ac8d19c829d5f3ba1602185acbbf1 (diff) | |
download | perl-71e9501eb5f515e4c2f2e89dacb9f682c4e7fb0f.tar.gz |
Move Object::Accessor from ext/ to cpan/
Diffstat (limited to 'cpan/Object-Accessor')
-rw-r--r-- | cpan/Object-Accessor/lib/Object/Accessor.pm | 819 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/00_Object-Accessor.t | 127 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t | 51 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/02_Object-Accessor-allow.t | 82 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/03_Object-Accessor-local.t | 50 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t | 82 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/05_Object-Accessor-callback.t | 97 | ||||
-rw-r--r-- | cpan/Object-Accessor/t/06_Object-Accessor-alias.t | 33 |
8 files changed, 1341 insertions, 0 deletions
diff --git a/cpan/Object-Accessor/lib/Object/Accessor.pm b/cpan/Object-Accessor/lib/Object/Accessor.pm new file mode 100644 index 0000000000..e5cd2660f0 --- /dev/null +++ b/cpan/Object-Accessor/lib/Object/Accessor.pm @@ -0,0 +1,819 @@ +package Object::Accessor; + +use strict; +use Carp qw[carp croak]; +use vars qw[$FATAL $DEBUG $AUTOLOAD $VERSION]; +use Params::Check qw[allow]; +use Data::Dumper; + +### some objects might have overload enabled, we'll need to +### disable string overloading for callbacks +require overload; + +$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 + +Object::Accessor + +=head1 SYNOPSIS + + ### using the object + $obj = Object::Accessor->new; # create object + $obj = Object::Accessor->new(@list); # create object with accessors + $obj = Object::Accessor->new(\%h); # create object with accessors + # and their allow handlers + + $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 + $bool = $obj->mk_flush; # clean out all data + + @list = $obj->ls_accessors; # retrieves a list of all + # accessors for this object + + $bar = $obj->foo('bar'); # set 'foo' to 'bar' + $bar = $obj->foo(); # retrieve 'bar' again + + $sub = $obj->can('foo'); # retrieve coderef for + # 'foo' accessor + $bar = $sub->('bar'); # set 'foo' via coderef + $bar = $sub->(); # retrieve 'bar' by coderef + + ### using the object as base class + package My::Class; + use base 'Object::Accessor'; + + $obj = My::Class->new; # create base object + $bool = $obj->mk_accessors('foo'); # create accessors, etc... + + ### make all attempted access to non-existant accessors fatal + ### (defaults to false) + $Object::Accessor::FATAL = 1; + + ### enable debugging + $Object::Accessor::DEBUG = 1; + + ### 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 + # behaviour and what is returned to the caller. + } + + ### advanced usage -- lvalue attributes + { my $obj = Object::Accessor::Lvalue->new('foo'); + print $obj->foo = 1; # will print 1 + } + + ### 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 + ### scope, 'foo's previous value will be restored + { $obj->foo( 2 => \my $x ); + print $obj->foo, ' ', $x; # will print '2 2' + } + print $obj->foo; # will print 1 + } + + +=head1 DESCRIPTION + +C<Object::Accessor> provides an interface to create per object +accessors (as opposed to per C<Class> accessors, as, for example, +C<Class::Accessor> provides). + +You can choose to either subclass this module, and thus using its +accessors on your own module, or to store an C<Object::Accessor> +object inside your own object, and access the accessors from there. +See the C<SYNOPSIS> for examples. + +=head1 METHODS + +=head2 $object = Object::Accessor->new( [ARGS] ); + +Creates a new (and empty) C<Object::Accessor> object. This method is +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 +C<Object::Acccessor::Lvalue> namespace instead. See the section +on C<LVALUE ACCESSORS> below. + +=cut + +sub new { + my $class = shift; + my $obj = bless {}, $class; + + $obj->mk_accessors( @_ ) if @_; + + return $obj; +} + +=head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP ); + +Creates a list of accessors for this object (and C<NOT> for other ones +in the same class!). +Will not clobber existing data, so if an accessor already exists, +requesting to create again is effectively a C<no-op>. + +When providing a C<hashref> as argument, rather than a normal list, +you can specify a list of key/value pairs of accessors and their +respective input validators. The validators can be anything that +C<Params::Check>'s C<allow> function accepts. Please see its manpage +for details. + +For example: + + $object->mk_accessors( { + foo => qr/^\d+$/, # digits only + bar => [0,1], # booleans + zot => \&my_sub # a custom verification sub + } ); + +Returns true on success, false on failure. + +Accessors that are called on an object, that do not exist return +C<undef> by default, but you can make this a fatal error by setting the +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 +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 +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 + ### 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. + +=cut + +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"); + next; + } + + __PACKAGE__->___debug( "Creating accessor '$acc'"); + + ### 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; + } + + return 1; +} + +=head2 @list = $self->ls_accessors; + +Returns a list of accessors that are supported by the current object. +The corresponding coderefs can be retrieved by passing this list one +by one to the C<can> method. + +=cut + +sub ls_accessors { + ### metainformation is stored in the stringified + ### key of the object, so skip that when listing accessors + return sort grep { $_ ne "$_[0]" } keys %{$_[0]}; +} + +=head2 $ref = $self->ls_allow(KEY) + +Returns the allow handler for the given key, which can be used with +C<Params::Check>'s C<allow()> handler. If there was no allow handler +specified, an allow handler that always returns true will be returned. + +=cut + +sub ls_allow { + my $self = shift; + my $key = shift or return; + return exists $self->{$key}->[ALLOW] + ? $self->{$key}->[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 +accessors as the current object, but without the data stored in them. + +=cut + +### XXX this creates an object WITH allow handlers at all times. +### even if the original didnt +sub mk_clone { + my $self = $_[0]; + 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) + 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 + $clone->mk_accessors( \%hash ) if %hash; + $clone->mk_accessors( @list ) if @list; + + ### copy callbacks + #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"}; + $clone->___callback( $self->___callback ); + + return $clone; +} + +=head2 $bool = $self->mk_flush; + +Flushes all the data from the current object; all accessors will be +set back to their default state of C<undef>. + +Returns true on success and false on failure. + +=cut + +sub mk_flush { + my $self = $_[0]; + + # set each accessor's data to undef + $self->{$_}->[VALUE] = undef for $self->ls_accessors; + + return 1; +} + +=head2 $bool = $self->mk_verify; + +Checks if all values in the current object are in accordance with their +own allow handler. Specifically useful to check if an empty initialised +object has been filled with values satisfying their own allow criteria. + +=cut + +sub mk_verify { + my $self = $_[0]; + + my $fail; + for my $name ( $self->ls_accessors ) { + unless( allow( $self->$name, $self->ls_allow( $name ) ) ) { + my $val = defined $self->$name ? $self->$name : '<undef>'; + + __PACKAGE__->___error("'$name' ($val) is invalid"); + $fail++; + } + } + + return if $fail; + return 1; +} + +=head2 $bool = $self->register_callback( sub { ... } ); + +This method allows you to register a callback, that is invoked +every time an accessor is called. This allows you to munge input +data, access external data stores, etc. + +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"] + # 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. + +=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 ); + + return 1; +} + + +=head2 $bool = $self->can( METHOD_NAME ) + +This method overrides C<UNIVERAL::can> in order to provide coderefs to +accessors which are loaded on demand. It will behave just like +C<UNIVERSAL::can> where it can -- returning a class method if it exists, +or a closure pointing to a valid accessor of this particular object. + +You can use it as follows: + + $sub = $object->can('some_accessor'); # retrieve the coderef + $sub->('foo'); # 'some_accessor' now set + # to 'foo' for $object + $foo = $sub->(); # retrieve the contents + # of 'some_accessor' + +See the C<SYNOPSIS> for more examples. + +=cut + +### custom 'can' as UNIVERSAL::can ignores autoload +sub can { + my($self, $method) = @_; + + ### it's one of our regular methods + if( $self->UNIVERSAL::can($method) ) { + __PACKAGE__->___debug( "Can '$method' -- provided by package" ); + return $self->UNIVERSAL::can($method); + } + + ### it's an accessor we provide; + if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) { + __PACKAGE__->___debug( "Can '$method' -- provided by object" ); + return sub { $self->$method(@_); } + } + + ### we don't support it + __PACKAGE__->___debug( "Cannot '$method'" ); + return; +} + +### don't autoload this +sub DESTROY { 1 }; + +### use autoload so we can have per-object accessors, +### not per class, as that is incorrect +sub AUTOLOAD { + my $self = shift; + my($method) = ($AUTOLOAD =~ /([^:']+$)/); + + my $val = $self->___autoload( $method, @_ ) or return; + + return $val->[0]; +} + +sub ___autoload { + my $self = shift; + my $method = shift; + my $assign = scalar @_; # is this an assignment? + + ### a method on our object + if( UNIVERSAL::isa( $self, 'HASH' ) ) { + if ( not exists $self->{$method} ) { + __PACKAGE__->___error("No such accessor '$method'", 1); + return; + } + + ### a method on something else, die with a descriptive error; + } else { + local $FATAL = 1; + __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 ); + + if( $assign ) { + + ### 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', + sub { $self->$method( $cur ) }; + + ${$_[0]} = $val; + + } else { + __PACKAGE__->___error( + "Can not bind '$method' to anything but a SCALAR", 1 + ); + } + } + + ### need to check the value? + if( exists $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 + ); + } + } + + ### callbacks? + if( my $sub = $self->___callback ) { + $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) }; + + ### register the error + $self->___error( $@, 1 ), return if $@; + } + + ### now we can actually assign it + if( $assign ) { + $self->___set( $method, $val ) or return; + } + + return [$val]; +} + +=head2 $val = $self->___get( METHOD_NAME ); + +Method to directly access the value of the given accessor in the +object. It circumvents all calls to allow checks, callbakcs, etc. + +Use only if you C<Know What You Are Doing>! General usage for +this functionality would be in your own custom callbacks. + +=cut + +### XXX O::A::lvalue is mirroring this behaviour! if this +### changes, lvalue's autoload must be changed as well +sub ___get { + my $self = shift; + my $method = shift or return; + return $self->{$method}->[VALUE]; +} + +=head2 $bool = $self->___set( METHOD_NAME => VALUE ); + +Method to directly set the value of the given accessor in the +object. It circumvents all calls to allow checks, callbakcs, etc. + +Use only if you C<Know What You Are Doing>! General usage for +this functionality would be in your own custom callbacks. + +=cut + +sub ___set { + my $self = shift; + my $method = shift or return; + + ### you didn't give us a value to set! + exists $_[0] 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! + $self->{$method}->[VALUE] = $val; + + 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; + + my $self = shift; + my $msg = shift; + my $lvl = shift || 0; + + local $Carp::CarpLevel += 1; + + carp($msg); +} + +sub ___error { + my $self = shift; + my $msg = shift; + my $lvl = shift || 0; + local $Carp::CarpLevel += ($lvl + 1); + $FATAL ? croak($msg) : carp($msg); +} + +### objects might be overloaded.. if so, we can't trust what "$self" +### will return, which might get *really* painful.. so check for that +### and get their unoverloaded stringval if needed. +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}; +} + +=head1 LVALUE ACCESSORS + +C<Object::Accessor> supports C<lvalue> attributes as well. To enable +these, you should create your objects in the designated namespace, +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. + +Doing the same on the standard C<Object>>Accessor> class would +generate the following code & errors: + + my $obj = Object::Accessor->new('foo'); + $obj->foo += 1; + + Can't modify non-lvalue subroutine call + +Note that C<lvalue> support on C<AUTOLOAD> routines is a +C<perl 5.8.x> feature. See perldoc L<perl58delta> for details. + +=head2 CAVEATS + +=over 4 + +=item * Allow handlers + +Due to the nature of C<lvalue subs>, we never get access to the +value you are assigning, so we can not check it againt your allow +handler. Allow handlers are therefor unsupported under C<lvalue> +conditions. + +See C<perldoc perlsub> for details. + +=item * Callbacks + +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 +under C<lvalue> conditions. + +See C<perldoc perlsub> for details. + + +=cut + +{ package Object::Accessor::Lvalue; + use base 'Object::Accessor'; + use strict; + use vars qw[$AUTOLOAD]; + + ### constants needed to access values from the objects + *VALUE = *Object::Accessor::VALUE; + *ALLOW = *Object::Accessor::ALLOW; + + ### largely copied from O::A::Autoload + sub AUTOLOAD : lvalue { + my $self = shift; + my($method) = ($AUTOLOAD =~ /([^:']+$)/); + + $self->___autoload( $method, @_ ) or return; + + ### *dont* add return to it, or it won't be stored + ### see perldoc perlsub on lvalue subs + ### XXX can't use $self->___get( ... ), as we MUST have + ### the container that's used for the lvalue assign as + ### the last statement... :( + $self->{$method}->[ VALUE() ]; + } + + 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 +{ package Object::Accessor::TIE; + use Tie::Scalar; + use Data::Dumper; + use base 'Tie::StdScalar'; + + my %local = (); + + sub TIESCALAR { + my $class = shift; + my $sub = shift; + my $ref = undef; + my $obj = bless \$ref, $class; + + ### 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->(); + } +} + +=back + +=head1 GLOBAL VARIABLES + +=head2 $Object::Accessor::FATAL + +Set this variable to true to make all attempted access to non-existant +accessors be fatal. +This defaults to C<false>. + +=head2 $Object::Accessor::DEBUG + +Set this variable to enable debugging output. +This defaults to C<false>. + +=head1 TODO + +=head2 Create read-only accessors + +Currently all accessors are read/write for everyone. Perhaps a future +release should make it possible to have read-only accessors as well. + +=head1 CAVEATS + +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 +reported, you should be aware of this issue when serializing your objects. + +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 E<lt>bug-object-accessor@rt.cpan.orgE<gt>. + +=head1 AUTHOR + +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 +under the same terms as Perl itself. + +=cut + +1; diff --git a/cpan/Object-Accessor/t/00_Object-Accessor.t b/cpan/Object-Accessor/t/00_Object-Accessor.t new file mode 100644 index 0000000000..e0f2f13b62 --- /dev/null +++ b/cpan/Object-Accessor/t/00_Object-Accessor.t @@ -0,0 +1,127 @@ + 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 $Err_re = qr/No such accessor '$Acc'/; + +### stupid warnings +### XXX this will break warning tests though if enabled +$Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; + + +### check the object +{ ok( $Object, "Object of '$Class' created" ); + isa_ok( $Object, $Class ); +} + +### check non existant accessor +{ my $warning; + local $SIG{__WARN__} = sub { $warning .= "@_" }; + + ok(!$Object->can($Acc), "Cannot '$Acc'" ); + ok(!$Object->$Acc(), " Method '$Acc' returns false" ); + like( $warning, $Err_re, " Warning logged" ); + + ### check fatal error + { local $Object::Accessor::FATAL = 1; + local $Object::Accessor::FATAL = 1; # stupid warnings + + my $rv = eval { $Object->$Acc() }; + + ok( $@, "Cannot '$Acc' -- dies" ); + ok(!$rv, " Method '$Acc' returns false" ); + like( $@, $Err_re, " Fatal error logged" ); + } +} + +### create an accessor; +{ my $warning; + local $SIG{__WARN__} = sub { $warning .= "@_" }; + + ok( $Object->mk_accessors( $Acc ), + "Accessor '$Acc' created" ); + + ok( $Object->can( $Acc ), " Can '$Acc'" ); + ok(!$warning, " No warnings logged" ); +} + +### try to use the accessor +{ for my $var ($0, $$) { + + ok( $Object->$Acc( $var ), "'$Acc' set to '$var'" ); + is( $Object->$Acc(), $var, " '$Acc' still holds '$var'" ); + + my $sub = $Object->can( $Acc ); + ok( $sub, "Retrieved '$Acc' coderef" ); + isa_ok( $sub, "CODE" ); + is( $sub->(), $var, " '$Acc' via coderef holds '$var'" ); + + ok( $sub->(1), " '$Acc' set via coderef to '1'" ); + is( $Object->$Acc(), 1, " '$Acc' still holds '1'" ); + } +} + +### get a list of accessors +{ my @list = $Object->ls_accessors; + ok( scalar(@list), "Accessors retrieved" ); + + for my $acc ( @list ) { + ok( $Object->can( $acc ), " Accessor '$acc' is valid" ); + } + + is_deeply( \@list, [$Acc], " Only expected accessors found" ); +} + +### clone the original +{ my $clone = $Object->mk_clone; + my @list = $clone->ls_accessors; + + ok( $clone, "Clone created" ); + isa_ok( $clone, $Class ); + ok( scalar(@list), " Clone has accessors" ); + is_deeply( \@list, [$Object->ls_accessors], + " Only expected accessors found" ); + + for my $acc ( @list ) { + ok( !defined( $clone->$acc() ), + " Accessor '$acc' is empty" ); + } +} + +### flush the original values +{ my $val = $Object->$Acc(); + ok( $val, "Objects '$Acc' has a value" ); + + ok( $Object->mk_flush, " Object flushed" ); + ok( !$Object->$Acc(), " Objects '$Acc' is now empty" ); +} + +### check that only our original object can do '$Acc' +{ my $warning; + local $SIG{__WARN__} = sub { $warning .= "@_" }; + + my $other = $Class->new; + + + ok(!$other->can($Acc), "Cannot '$Acc' via other object" ); + ok(!$other->$Acc(), " Method '$Acc' returns false" ); + like( $warning, $Err_re, " Warning logged" ); +} + +### check if new() passes it's args correctly +{ my $obj = $Class->new( $Acc ); + ok( $obj, "Object created with accessors" ); + isa_ok( $obj, $Class ); + can_ok( $obj, $Acc ); +} + +1; diff --git a/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t b/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t new file mode 100644 index 0000000000..8ebe7f1343 --- /dev/null +++ b/cpan/Object-Accessor/t/01_Object-Accessor-Subclassed.t @@ -0,0 +1,51 @@ +BEGIN { chdir 't' if -d 't' }; + +use strict; +use lib '../lib'; +use Test::More 'no_plan'; +use Data::Dumper; + +my $Class = 'Object::Accessor'; +my $MyClass = 'My::Class'; +my $Acc = 'foo'; + +use_ok($Class); + +### establish another package that subclasses our own +{ package My::Class; + use base 'Object::Accessor'; +} + +my $Object = $MyClass->new; + +### check the object +{ ok( $Object, "Object created" ); + isa_ok( $Object, $MyClass ); + isa_ok( $Object, $Class ); +} + +### 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 +### 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; +{ eval { $MyClass->$$ }; + + 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 new file mode 100644 index 0000000000..396ef2b6f0 --- /dev/null +++ b/cpan/Object-Accessor/t/02_Object-Accessor-allow.t @@ -0,0 +1,82 @@ +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 $Allow = qr/^\d+$/; +my $Err_re = qr/is an invalid value for '$Acc'/; +my ($Ver_re) = map { qr/$_/ } quotemeta qq['$Acc' (<undef>) is invalid]; + +### stupid warnings +### XXX this will break warning tests though if enabled +$Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; + + +### check the object +{ ok( $Object, "Object of '$Class' created" ); + isa_ok( $Object, $Class ); +} + +### create an accessor; +{ my $warning; + local $SIG{__WARN__} = sub { $warning .= "@_" }; + + ok( $Object->mk_accessors( { $Acc => $Allow } ), + "Accessor '$Acc' created" ); + + ok( $Object->can( $Acc ), " Can '$Acc'" ); + ok(!$warning, " No warnings logged" ); + is( $Object->ls_allow( $Acc ), $Allow, + " Proper allow handler stored" ); + + +} + +### try to use the accessor +{ ### 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" ); + } + + $Object->mk_flush; + + ### 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" ); + + } + + $Object->mk_flush; + +} diff --git a/cpan/Object-Accessor/t/03_Object-Accessor-local.t b/cpan/Object-Accessor/t/03_Object-Accessor-local.t new file mode 100644 index 0000000000..f085683c3a --- /dev/null +++ b/cpan/Object-Accessor/t/03_Object-Accessor-local.t @@ -0,0 +1,50 @@ +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'; + +### stupid warnings +### XXX this will break warning tests though if enabled +$Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; + + +### check the object +{ ok( $Object, "Object of '$Class' created" ); + isa_ok( $Object, $Class ); +} + +### create an accessor; +{ my $warning; + local $SIG{__WARN__} = sub { $warning .= "@_" }; + + ok( $Object->mk_accessors( $Acc ), + "Accessor '$Acc' created" ); + + ok( $Object->can( $Acc ), " Can '$Acc'" ); + ok(!$warning, " No warnings logged" ); + + +} + +### scoped variables +{ ok( 1, "Testing scoped values" ); + + $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 new file mode 100644 index 0000000000..092c74169a --- /dev/null +++ b/cpan/Object-Accessor/t/04_Object-Accessor-lvalue.t @@ -0,0 +1,82 @@ +BEGIN { chdir 't' if -d 't' }; + +use strict; +use lib '../lib'; +use Data::Dumper; + +BEGIN { + require Test::More; + Test::More->import( + # silly bbedit [ + $] >= 5.008 + ? 'no_plan' + : ( skip_all => "Lvalue objects require perl >= 5.8" ) + ); +} + +my $Class = 'Object::Accessor'; +my $LClass = $Class . '::Lvalue'; + +use_ok($Class); + +my $Object = $LClass->new; +my $Acc = 'foo'; + +### stupid warnings +### XXX this will break warning tests though if enabled +$Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; + + +### check the object +{ ok( $Object, "Object of '$LClass' created" ); + isa_ok( $Object, $LClass ); + isa_ok( $Object, $Class ); + ok( $Object->mk_clone, " Object cloned" ); +} + +### create an accessor; +{ ok( $Object->mk_accessors( $Acc ), + "Accessor '$Acc' created" ); + + eval { $Object->$Acc = $$ }; + ok( !$@, "lvalue assign successful $@" ); + ok( $Object->$Acc, "Accessor '$Acc' set" ); + is( $Object->$Acc, $$, " Contains proper value" ); +} + +### test allow handlers +{ my $acc = 'bar'; + my $clone = $Object->mk_clone; + + ok( $clone, "Cloned the lvalue object" ); + + ### lets see if this causes a warning + { my $warnings; + local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + ok( $clone->mk_accessors({ $acc => sub { 0 } }), + " Created accessor '$acc'" ); + like( $warnings, qr/not supported/, + " Got warning about allow handlers" ); + } + + ok( eval{ $clone->$acc = $$ }, + " Allow handler ignored" ); + ok( ! $@, " No error occurred" ); + is( $clone->$acc, $$, " Setting '$acc' worked" ); +} + +### 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 { } ), + "Callback not registered" ); + + 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 new file mode 100644 index 0000000000..5411bbdd0d --- /dev/null +++ b/cpan/Object-Accessor/t/05_Object-Accessor-callback.t @@ -0,0 +1,97 @@ +BEGIN { chdir 't' if -d 't' }; + +use strict; +use lib '../lib'; +use Test::More 'no_plan'; +use Data::Dumper; + +my $Class = 'Object::Accessor'; +my $LClass = $Class . '::Lvalue'; + +use_ok($Class); + +### stupid warnings +### XXX this will break warning tests though if enabled +$Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; + +my $Object = $Class->new; +my $Acc = 'foo'; +my $Func = 'register_callback'; +my $Called = 0; +my $RetVal = $$; +my $SetVal = 1; + +### 6 tests +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 + ? is( $val->[0], $SetVal, + " Attempted to set $SetVal" ) + : ok( ! exists $val->[0], + " This was a GET request" ); + + return $RetVal; +}; + +### set up the object +{ ok( $Object, "Object created" ); + isa_ok( $Object, $Class ); + ok( $Object->mk_accessors( $Acc ), + " Accessor '$Acc' created" ); + can_ok( $Object, $Func ); + ok( $Object->$Func( $Sub ), " Callback registered" ); +} + +### test ___get and ___set +{ $Called = 0; + + 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" ); +} + +### 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>" ); + ok( $Called, " Callback called" ); + + + #diag("Running SET tests on regular objects"); + $Called = 0; + ok( $clone->$Acc($SetVal), " Setting $Acc" ); + ok( $Called, " Callback called" ); + + $Called = 0; + is( $clone->$Acc, $RetVal, " Returns $RetVal" ); + ok( $Called, " Callback called" ); + + $Called = 0; + is( $clone->___get( $Acc ), $RetVal, + " Direct get returns $RetVal" ); + ok( !$Called, " Callback not called" ); +} diff --git a/cpan/Object-Accessor/t/06_Object-Accessor-alias.t b/cpan/Object-Accessor/t/06_Object-Accessor-alias.t new file mode 100644 index 0000000000..2a8aa81f0d --- /dev/null +++ b/cpan/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" ); +} |