1 package Object::Accessor;
4 use Carp qw[carp croak];
5 use vars qw[$FATAL $DEBUG $AUTOLOAD $VERSION];
6 use Params::Check qw[allow];
9 ### some objects might have overload enabled, we'll need to
10 ### disable string overloading for callbacks
17 use constant VALUE => 0; # array index in the hash value
18 use constant ALLOW => 1; # array index in the hash value
19 use constant ALIAS => 2; # array index in the hash value
28 $obj = Object::Accessor->new; # create object
29 $obj = Object::Accessor->new(@list); # create object with accessors
30 $obj = Object::Accessor->new(\%h); # create object with accessors
31 # and their allow handlers
33 $bool = $obj->mk_accessors('foo'); # create accessors
34 $bool = $obj->mk_accessors( # create accessors with input
35 {foo => ALLOW_HANDLER} ); # validation
37 $bool = $obj->mk_aliases( # create an alias to an existing
38 alias_name => 'method'); # method name
40 $clone = $obj->mk_clone; # create a clone of original
42 $bool = $obj->mk_flush; # clean out all data
44 @list = $obj->ls_accessors; # retrieves a list of all
45 # accessors for this object
47 $bar = $obj->foo('bar'); # set 'foo' to 'bar'
48 $bar = $obj->foo(); # retrieve 'bar' again
50 $sub = $obj->can('foo'); # retrieve coderef for
52 $bar = $sub->('bar'); # set 'foo' via coderef
53 $bar = $sub->(); # retrieve 'bar' by coderef
55 ### using the object as base class
57 use base 'Object::Accessor';
59 $obj = My::Class->new; # create base object
60 $bool = $obj->mk_accessors('foo'); # create accessors, etc...
62 ### make all attempted access to non-existant accessors fatal
63 ### (defaults to false)
64 $Object::Accessor::FATAL = 1;
67 $Object::Accessor::DEBUG = 1;
69 ### advanced usage -- callbacks
70 { my $obj = Object::Accessor->new('foo');
71 $obj->register_callback( sub { ... } );
73 $obj->foo( 1 ); # these calls invoke the callback you registered
74 $obj->foo() # which allows you to change the get/set
75 # behaviour and what is returned to the caller.
78 ### advanced usage -- lvalue attributes
79 { my $obj = Object::Accessor::Lvalue->new('foo');
80 print $obj->foo = 1; # will print 1
83 ### advanced usage -- scoped attribute values
84 { my $obj = Object::Accessor->new('foo');
87 print $obj->foo; # will print 1
89 ### bind the scope of the value of attribute 'foo'
90 ### to the scope of '$x' -- when $x goes out of
91 ### scope, 'foo's previous value will be restored
92 { $obj->foo( 2 => \my $x );
93 print $obj->foo, ' ', $x; # will print '2 2'
95 print $obj->foo; # will print 1
101 C<Object::Accessor> provides an interface to create per object
102 accessors (as opposed to per C<Class> accessors, as, for example,
103 C<Class::Accessor> provides).
105 You can choose to either subclass this module, and thus using its
106 accessors on your own module, or to store an C<Object::Accessor>
107 object inside your own object, and access the accessors from there.
108 See the C<SYNOPSIS> for examples.
112 =head2 $object = Object::Accessor->new( [ARGS] );
114 Creates a new (and empty) C<Object::Accessor> object. This method is
117 Any arguments given to C<new> are passed straight to C<mk_accessors>.
119 If you want to be able to assign to your accessors as if they
120 were C<lvalue>s, you should create your object in the
121 C<Object::Acccessor::Lvalue> namespace instead. See the section
122 on C<LVALUE ACCESSORS> below.
128 my $obj = bless {}, $class;
130 $obj->mk_accessors( @_ ) if @_;
135 =head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP );
137 Creates a list of accessors for this object (and C<NOT> for other ones
139 Will not clobber existing data, so if an accessor already exists,
140 requesting to create again is effectively a C<no-op>.
142 When providing a C<hashref> as argument, rather than a normal list,
143 you can specify a list of key/value pairs of accessors and their
144 respective input validators. The validators can be anything that
145 C<Params::Check>'s C<allow> function accepts. Please see its manpage
150 $object->mk_accessors( {
151 foo => qr/^\d+$/, # digits only
152 bar => [0,1], # booleans
153 zot => \&my_sub # a custom verification sub
156 Returns true on success, false on failure.
158 Accessors that are called on an object, that do not exist return
159 C<undef> by default, but you can make this a fatal error by setting the
160 global variable C<$FATAL> to true. See the section on C<GLOBAL
161 VARIABLES> for details.
163 Note that you can bind the values of attributes to a scope. This allows
164 you to C<temporarily> change a value of an attribute, and have it's
165 original value restored up on the end of it's bound variable's scope;
167 For example, in this snippet of code, the attribute C<foo> will
168 temporarily be set to C<2>, until the end of the scope of C<$x>, at
169 which point the original value of C<1> will be restored.
171 my $obj = Object::Accessor->new;
173 $obj->mk_accessors('foo');
175 print $obj->foo; # will print 1
177 ### bind the scope of the value of attribute 'foo'
178 ### to the scope of '$x' -- when $x goes out of
179 ### scope, 'foo' previous value will be restored
180 { $obj->foo( 2 => \my $x );
181 print $obj->foo, ' ', $x; # will print '2 2'
183 print $obj->foo; # will print 1
186 Note that all accessors are read/write for everyone. See the C<TODO>
193 my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' );
195 ### first argument is a hashref, which means key/val pairs
196 ### as keys + allow handlers
197 for my $acc ( $is_hash ? keys %{$_[1]} : @_[1..$#_] ) {
199 ### already created apparently
200 if( exists $self->{$acc} ) {
201 __PACKAGE__->___debug( "Accessor '$acc' already exists");
205 __PACKAGE__->___debug( "Creating accessor '$acc'");
207 ### explicitly vivify it, so that exists works in ls_accessors()
208 $self->{$acc}->[VALUE] = undef;
210 ### set the allow handler only if one was specified
211 $self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash;
217 =head2 @list = $self->ls_accessors;
219 Returns a list of accessors that are supported by the current object.
220 The corresponding coderefs can be retrieved by passing this list one
221 by one to the C<can> method.
226 ### metainformation is stored in the stringified
227 ### key of the object, so skip that when listing accessors
228 return sort grep { $_ ne "$_[0]" } keys %{$_[0]};
231 =head2 $ref = $self->ls_allow(KEY)
233 Returns the allow handler for the given key, which can be used with
234 C<Params::Check>'s C<allow()> handler. If there was no allow handler
235 specified, an allow handler that always returns true will be returned.
241 my $key = shift or return;
242 return exists $self->{$key}->[ALLOW]
243 ? $self->{$key}->[ALLOW]
247 =head2 $bool = $self->mk_aliases( alias => method, [alias2 => method2, ...] );
249 Creates an alias for a given method name. For all intents and purposes,
250 these two accessors are now identical for this object. This is akin to
251 doing the following on the symbol table level:
255 This allows you to do the following:
257 $self->mk_accessors('foo');
258 $self->mk_aliases( bar => 'foo' );
261 print $self->foo; # will print 42
269 while( my($alias, $method) = each %aliases ) {
271 ### already created apparently
272 if( exists $self->{$alias} ) {
273 __PACKAGE__->___debug( "Accessor '$alias' already exists");
277 $self->___alias( $alias => $method );
283 =head2 $clone = $self->mk_clone;
285 Makes a clone of the current object, which will have the exact same
286 accessors as the current object, but without the data stored in them.
290 ### XXX this creates an object WITH allow handlers at all times.
291 ### even if the original didnt
294 my $class = ref $self;
296 my $clone = $class->new;
298 ### split out accessors with and without allow handlers, so we
299 ### don't install dummy allow handers (which makes O::A::lvalue
300 ### warn for example)
302 for my $acc ( $self->ls_accessors ) {
303 my $allow = $self->{$acc}->[ALLOW];
304 $allow ? $hash{$acc} = $allow : push @list, $acc;
306 ### is this an alias?
307 if( my $org = $self->{ $acc }->[ ALIAS ] ) {
308 $clone->___alias( $acc => $org );
312 ### copy the accessors from $self to $clone
313 $clone->mk_accessors( \%hash ) if %hash;
314 $clone->mk_accessors( @list ) if @list;
317 #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
318 $clone->___callback( $self->___callback );
323 =head2 $bool = $self->mk_flush;
325 Flushes all the data from the current object; all accessors will be
326 set back to their default state of C<undef>.
328 Returns true on success and false on failure.
335 # set each accessor's data to undef
336 $self->{$_}->[VALUE] = undef for $self->ls_accessors;
341 =head2 $bool = $self->mk_verify;
343 Checks if all values in the current object are in accordance with their
344 own allow handler. Specifically useful to check if an empty initialised
345 object has been filled with values satisfying their own allow criteria.
353 for my $name ( $self->ls_accessors ) {
354 unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
355 my $val = defined $self->$name ? $self->$name : '<undef>';
357 __PACKAGE__->___error("'$name' ($val) is invalid");
366 =head2 $bool = $self->register_callback( sub { ... } );
368 This method allows you to register a callback, that is invoked
369 every time an accessor is called. This allows you to munge input
370 data, access external data stores, etc.
372 You are free to return whatever you wish. On a C<set> call, the
373 data is even stored in the object.
375 Below is an example of the use of a callback.
377 $object->some_method( "some_value" );
380 my $self = shift; # the object
381 my $meth = shift; # "some_method"
382 my $val = shift; # ["some_value"]
383 # could be undef -- check 'exists';
384 # if scalar @$val is empty, it was a 'get'
388 return $new_val; # the value you want to be set/returned
391 To access the values stored in the object, circumventing the
392 callback structure, you should use the C<___get> and C<___set> methods
393 documented further down.
397 sub register_callback {
399 my $sub = shift or return;
401 ### use the memory address as key, it's not used EVER as an
403 $self->___callback( $sub );
409 =head2 $bool = $self->can( METHOD_NAME )
411 This method overrides C<UNIVERAL::can> in order to provide coderefs to
412 accessors which are loaded on demand. It will behave just like
413 C<UNIVERSAL::can> where it can -- returning a class method if it exists,
414 or a closure pointing to a valid accessor of this particular object.
416 You can use it as follows:
418 $sub = $object->can('some_accessor'); # retrieve the coderef
419 $sub->('foo'); # 'some_accessor' now set
420 # to 'foo' for $object
421 $foo = $sub->(); # retrieve the contents
424 See the C<SYNOPSIS> for more examples.
428 ### custom 'can' as UNIVERSAL::can ignores autoload
430 my($self, $method) = @_;
432 ### it's one of our regular methods
433 if( $self->UNIVERSAL::can($method) ) {
434 __PACKAGE__->___debug( "Can '$method' -- provided by package" );
435 return $self->UNIVERSAL::can($method);
438 ### it's an accessor we provide;
439 if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) {
440 __PACKAGE__->___debug( "Can '$method' -- provided by object" );
441 return sub { $self->$method(@_); }
444 ### we don't support it
445 __PACKAGE__->___debug( "Cannot '$method'" );
449 ### don't autoload this
452 ### use autoload so we can have per-object accessors,
453 ### not per class, as that is incorrect
456 my($method) = ($AUTOLOAD =~ /([^:']+$)/);
458 my $val = $self->___autoload( $method, @_ ) or return;
466 my $assign = scalar @_; # is this an assignment?
468 ### a method on our object
469 if( UNIVERSAL::isa( $self, 'HASH' ) ) {
470 if ( not exists $self->{$method} ) {
471 __PACKAGE__->___error("No such accessor '$method'", 1);
475 ### a method on something else, die with a descriptive error;
478 __PACKAGE__->___error(
479 "You called '$AUTOLOAD' on '$self' which was interpreted by ".
480 __PACKAGE__ . " as an object call. Did you mean to include ".
481 "'$method' from somewhere else?", 1 );
484 ### is this is an alias, redispatch to the original method
485 if( my $original = $self->{ $method }->[ALIAS] ) {
486 return $self->___autoload( $original, @_ );
490 my $val = $assign ? shift(@_) : $self->___get( $method );
496 if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
498 ### tie the reference, so we get an object and
499 ### we can use it's going out of scope to restore
501 my $cur = $self->{$method}->[VALUE];
503 tie ${$_[0]}, __PACKAGE__ . '::TIE',
504 sub { $self->$method( $cur ) };
509 __PACKAGE__->___error(
510 "Can not bind '$method' to anything but a SCALAR", 1
515 ### need to check the value?
516 if( exists $self->{$method}->[ALLOW] ) {
518 ### double assignment due to 'used only once' warnings
519 local $Params::Check::VERBOSE = 0;
520 local $Params::Check::VERBOSE = 0;
522 allow( $val, $self->{$method}->[ALLOW] ) or (
523 __PACKAGE__->___error(
524 "'$val' is an invalid value for '$method'", 1),
531 if( my $sub = $self->___callback ) {
532 $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
534 ### register the error
535 $self->___error( $@, 1 ), return if $@;
538 ### now we can actually assign it
540 $self->___set( $method, $val ) or return;
546 =head2 $val = $self->___get( METHOD_NAME );
548 Method to directly access the value of the given accessor in the
549 object. It circumvents all calls to allow checks, callbakcs, etc.
551 Use only if you C<Know What You Are Doing>! General usage for
552 this functionality would be in your own custom callbacks.
556 ### XXX O::A::lvalue is mirroring this behaviour! if this
557 ### changes, lvalue's autoload must be changed as well
560 my $method = shift or return;
561 return $self->{$method}->[VALUE];
564 =head2 $bool = $self->___set( METHOD_NAME => VALUE );
566 Method to directly set the value of the given accessor in the
567 object. It circumvents all calls to allow checks, callbakcs, etc.
569 Use only if you C<Know What You Are Doing>! General usage for
570 this functionality would be in your own custom callbacks.
576 my $method = shift or return;
578 ### you didn't give us a value to set!
579 exists $_[0] or return;
582 ### if there's more arguments than $self, then
583 ### replace the method called by the accessor.
584 ### XXX implement rw vs ro accessors!
585 $self->{$method}->[VALUE] = $val;
590 =head2 $bool = $self->___alias( ALIAS => METHOD );
592 Method to directly alias one accessor to another for
593 this object. It circumvents all sanity checks, etc.
595 Use only if you C<Know What You Are Doing>!
601 my $alias = shift or return;
602 my $method = shift or return;
604 $self->{ $alias }->[ALIAS] = $method;
610 return unless $DEBUG;
614 my $lvl = shift || 0;
616 local $Carp::CarpLevel += 1;
624 my $lvl = shift || 0;
625 local $Carp::CarpLevel += ($lvl + 1);
626 $FATAL ? croak($msg) : carp($msg);
629 ### objects might be overloaded.. if so, we can't trust what "$self"
630 ### will return, which might get *really* painful.. so check for that
631 ### and get their unoverloaded stringval if needed.
636 my $mem = overload::Overloaded( $self )
637 ? overload::StrVal( $self )
640 $self->{$mem} = $sub if $sub;
642 return $self->{$mem};
645 =head1 LVALUE ACCESSORS
647 C<Object::Accessor> supports C<lvalue> attributes as well. To enable
648 these, you should create your objects in the designated namespace,
649 C<Object::Accessor::Lvalue>. For example:
651 my $obj = Object::Accessor::Lvalue->new('foo');
655 will actually print C<1> and work as expected. Since this is an
656 optional feature, that's not desirable in all cases, we require
657 you to explicitly use the C<Object::Accessor::Lvalue> class.
659 Doing the same on the standard C<Object>>Accessor> class would
660 generate the following code & errors:
662 my $obj = Object::Accessor->new('foo');
665 Can't modify non-lvalue subroutine call
667 Note that C<lvalue> support on C<AUTOLOAD> routines is a
668 C<perl 5.8.x> feature. See perldoc L<perl58delta> for details.
674 =item * Allow handlers
676 Due to the nature of C<lvalue subs>, we never get access to the
677 value you are assigning, so we can not check it againt your allow
678 handler. Allow handlers are therefor unsupported under C<lvalue>
681 See C<perldoc perlsub> for details.
685 Due to the nature of C<lvalue subs>, we never get access to the
686 value you are assigning, so we can not check provide this value
687 to your callback. Furthermore, we can not distinguish between
688 a C<get> and a C<set> call. Callbacks are therefor unsupported
689 under C<lvalue> conditions.
691 See C<perldoc perlsub> for details.
696 { package Object::Accessor::Lvalue;
697 use base 'Object::Accessor';
699 use vars qw[$AUTOLOAD];
701 ### constants needed to access values from the objects
702 *VALUE = *Object::Accessor::VALUE;
703 *ALLOW = *Object::Accessor::ALLOW;
705 ### largely copied from O::A::Autoload
706 sub AUTOLOAD : lvalue {
708 my($method) = ($AUTOLOAD =~ /([^:']+$)/);
710 $self->___autoload( $method, @_ ) or return;
712 ### *dont* add return to it, or it won't be stored
713 ### see perldoc perlsub on lvalue subs
714 ### XXX can't use $self->___get( ... ), as we MUST have
715 ### the container that's used for the lvalue assign as
716 ### the last statement... :(
717 $self->{$method}->[ VALUE() ];
722 my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
725 "Allow handlers are not supported for '". __PACKAGE__ ."' objects"
728 return $self->SUPER::mk_accessors( @_ );
731 sub register_callback {
734 "Callbacks are not supported for '". __PACKAGE__ ."' objects"
741 ### standard tie class for bound attributes
742 { package Object::Accessor::TIE;
745 use base 'Tie::StdScalar';
753 my $obj = bless \$ref, $class;
755 ### store the restore sub
756 $local{ $obj } = $sub;
762 my $sub = delete $local{ $tied };
764 ### run the restore sub to set the old value back
771 =head1 GLOBAL VARIABLES
773 =head2 $Object::Accessor::FATAL
775 Set this variable to true to make all attempted access to non-existant
777 This defaults to C<false>.
779 =head2 $Object::Accessor::DEBUG
781 Set this variable to enable debugging output.
782 This defaults to C<false>.
786 =head2 Create read-only accessors
788 Currently all accessors are read/write for everyone. Perhaps a future
789 release should make it possible to have read-only accessors as well.
793 If you use codereferences for your allow handlers, you will not be able
794 to freeze the data structures using C<Storable>.
796 Due to a bug in storable (until at least version 2.15), C<qr//> compiled
797 regexes also don't de-serialize properly. Although this bug has been
798 reported, you should be aware of this issue when serializing your objects.
800 You can track the bug here:
802 http://rt.cpan.org/Ticket/Display.html?id=1827
806 Please report bugs or other issues to E<lt>bug-object-accessor@rt.cpan.orgE<gt>.
810 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
814 This library is free software; you may redistribute and/or modify it
815 under the same terms as Perl itself.