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
27 $obj = Object::Accessor->new; # create object
28 $obj = Object::Accessor->new(@list); # create object with accessors
29 $obj = Object::Accessor->new(\%h); # create object with accessors
30 # and their allow handlers
32 $bool = $obj->mk_accessors('foo'); # create accessors
33 $bool = $obj->mk_accessors( # create accessors with input
34 {foo => ALLOW_HANDLER} ); # validation
36 $clone = $obj->mk_clone; # create a clone of original
38 $bool = $obj->mk_flush; # clean out all data
40 @list = $obj->ls_accessors; # retrieves a list of all
41 # accessors for this object
43 $bar = $obj->foo('bar'); # set 'foo' to 'bar'
44 $bar = $obj->foo(); # retrieve 'bar' again
46 $sub = $obj->can('foo'); # retrieve coderef for
48 $bar = $sub->('bar'); # set 'foo' via coderef
49 $bar = $sub->(); # retrieve 'bar' by coderef
51 ### using the object as base class
53 use base 'Object::Accessor';
55 $obj = My::Class->new; # create base object
56 $bool = $obj->mk_accessors('foo'); # create accessors, etc...
58 ### make all attempted access to non-existant accessors fatal
59 ### (defaults to false)
60 $Object::Accessor::FATAL = 1;
63 $Object::Accessor::DEBUG = 1;
65 ### advanced usage -- callbacks
66 { my $obj = Object::Accessor->new('foo');
67 $obj->register_callback( sub { ... } );
69 $obj->foo( 1 ); # these calls invoke the callback you registered
70 $obj->foo() # which allows you to change the get/set
71 # behaviour and what is returned to the caller.
74 ### advanced usage -- lvalue attributes
75 { my $obj = Object::Accessor::Lvalue->new('foo');
76 print $obj->foo = 1; # will print 1
79 ### advanced usage -- scoped attribute values
80 { my $obj = Object::Accessor->new('foo');
83 print $obj->foo; # will print 1
85 ### bind the scope of the value of attribute 'foo'
86 ### to the scope of '$x' -- when $x goes out of
87 ### scope, 'foo's previous value will be restored
88 { $obj->foo( 2 => \my $x );
89 print $obj->foo, ' ', $x; # will print '2 2'
91 print $obj->foo; # will print 1
97 C<Object::Accessor> provides an interface to create per object
98 accessors (as opposed to per C<Class> accessors, as, for example,
99 C<Class::Accessor> provides).
101 You can choose to either subclass this module, and thus using its
102 accessors on your own module, or to store an C<Object::Accessor>
103 object inside your own object, and access the accessors from there.
104 See the C<SYNOPSIS> for examples.
108 =head2 $object = Object::Accessor->new( [ARGS] );
110 Creates a new (and empty) C<Object::Accessor> object. This method is
113 Any arguments given to C<new> are passed straight to C<mk_accessors>.
115 If you want to be able to assign to your accessors as if they
116 were C<lvalue>s, you should create your object in the
117 C<Object::Acccessor::Lvalue> namespace instead. See the section
118 on C<LVALUE ACCESSORS> below.
124 my $obj = bless {}, $class;
126 $obj->mk_accessors( @_ ) if @_;
131 =head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP );
133 Creates a list of accessors for this object (and C<NOT> for other ones
135 Will not clobber existing data, so if an accessor already exists,
136 requesting to create again is effectively a C<no-op>.
138 When providing a C<hashref> as argument, rather than a normal list,
139 you can specify a list of key/value pairs of accessors and their
140 respective input validators. The validators can be anything that
141 C<Params::Check>'s C<allow> function accepts. Please see its manpage
146 $object->mk_accessors( {
147 foo => qr/^\d+$/, # digits only
148 bar => [0,1], # booleans
149 zot => \&my_sub # a custom verification sub
152 Returns true on success, false on failure.
154 Accessors that are called on an object, that do not exist return
155 C<undef> by default, but you can make this a fatal error by setting the
156 global variable C<$FATAL> to true. See the section on C<GLOBAL
157 VARIABLES> for details.
159 Note that you can bind the values of attributes to a scope. This allows
160 you to C<temporarily> change a value of an attribute, and have it's
161 original value restored up on the end of it's bound variable's scope;
163 For example, in this snippet of code, the attribute C<foo> will
164 temporarily be set to C<2>, until the end of the scope of C<$x>, at
165 which point the original value of C<1> will be restored.
167 my $obj = Object::Accessor->new;
169 $obj->mk_accessors('foo');
171 print $obj->foo; # will print 1
173 ### bind the scope of the value of attribute 'foo'
174 ### to the scope of '$x' -- when $x goes out of
175 ### scope, 'foo' previous value will be restored
176 { $obj->foo( 2 => \my $x );
177 print $obj->foo, ' ', $x; # will print '2 2'
179 print $obj->foo; # will print 1
182 Note that all accessors are read/write for everyone. See the C<TODO>
189 my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' );
191 ### first argument is a hashref, which means key/val pairs
192 ### as keys + allow handlers
193 for my $acc ( $is_hash ? keys %{$_[1]} : @_[1..$#_] ) {
195 ### already created apparently
196 if( exists $self->{$acc} ) {
197 __PACKAGE__->___debug( "Accessor '$acc' already exists");
201 __PACKAGE__->___debug( "Creating accessor '$acc'");
203 ### explicitly vivify it, so that exists works in ls_accessors()
204 $self->{$acc}->[VALUE] = undef;
206 ### set the allow handler only if one was specified
207 $self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash;
213 =head2 @list = $self->ls_accessors;
215 Returns a list of accessors that are supported by the current object.
216 The corresponding coderefs can be retrieved by passing this list one
217 by one to the C<can> method.
222 ### metainformation is stored in the stringified
223 ### key of the object, so skip that when listing accessors
224 return sort grep { $_ ne "$_[0]" } keys %{$_[0]};
227 =head2 $ref = $self->ls_allow(KEY)
229 Returns the allow handler for the given key, which can be used with
230 C<Params::Check>'s C<allow()> handler. If there was no allow handler
231 specified, an allow handler that always returns true will be returned.
237 my $key = shift or return;
238 return exists $self->{$key}->[ALLOW]
239 ? $self->{$key}->[ALLOW]
243 =head2 $clone = $self->mk_clone;
245 Makes a clone of the current object, which will have the exact same
246 accessors as the current object, but without the data stored in them.
250 ### XXX this creates an object WITH allow handlers at all times.
251 ### even if the original didnt
254 my $class = ref $self;
256 my $clone = $class->new;
258 ### split out accessors with and without allow handlers, so we
259 ### don't install dummy allow handers (which makes O::A::lvalue
260 ### warn for exampel)
262 for my $acc ( $self->ls_accessors ) {
263 my $allow = $self->{$acc}->[ALLOW];
264 $allow ? $hash{$acc} = $allow : push @list, $acc;
267 ### copy the accessors from $self to $clone
268 $clone->mk_accessors( \%hash ) if %hash;
269 $clone->mk_accessors( @list ) if @list;
272 #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
273 $clone->___callback( $self->___callback );
278 =head2 $bool = $self->mk_flush;
280 Flushes all the data from the current object; all accessors will be
281 set back to their default state of C<undef>.
283 Returns true on success and false on failure.
290 # set each accessor's data to undef
291 $self->{$_}->[VALUE] = undef for $self->ls_accessors;
296 =head2 $bool = $self->mk_verify;
298 Checks if all values in the current object are in accordance with their
299 own allow handler. Specifically useful to check if an empty initialised
300 object has been filled with values satisfying their own allow criteria.
308 for my $name ( $self->ls_accessors ) {
309 unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
310 my $val = defined $self->$name ? $self->$name : '<undef>';
312 __PACKAGE__->___error("'$name' ($val) is invalid");
321 =head2 $bool = $self->register_callback( sub { ... } );
323 This method allows you to register a callback, that is invoked
324 every time an accessor is called. This allows you to munge input
325 data, access external data stores, etc.
327 You are free to return whatever you wish. On a C<set> call, the
328 data is even stored in the object.
330 Below is an example of the use of a callback.
332 $object->some_method( "some_value" );
335 my $self = shift; # the object
336 my $meth = shift; # "some_method"
337 my $val = shift; # ["some_value"]
338 # could be undef -- check 'exists';
339 # if scalar @$val is empty, it was a 'get'
343 return $new_val; # the value you want to be set/returned
346 To access the values stored in the object, circumventing the
347 callback structure, you should use the C<___get> and C<___set> methods
348 documented further down.
352 sub register_callback {
354 my $sub = shift or return;
356 ### use the memory address as key, it's not used EVER as an
358 $self->___callback( $sub );
364 =head2 $bool = $self->can( METHOD_NAME )
366 This method overrides C<UNIVERAL::can> in order to provide coderefs to
367 accessors which are loaded on demand. It will behave just like
368 C<UNIVERSAL::can> where it can -- returning a class method if it exists,
369 or a closure pointing to a valid accessor of this particular object.
371 You can use it as follows:
373 $sub = $object->can('some_accessor'); # retrieve the coderef
374 $sub->('foo'); # 'some_accessor' now set
375 # to 'foo' for $object
376 $foo = $sub->(); # retrieve the contents
379 See the C<SYNOPSIS> for more examples.
383 ### custom 'can' as UNIVERSAL::can ignores autoload
385 my($self, $method) = @_;
387 ### it's one of our regular methods
388 if( $self->UNIVERSAL::can($method) ) {
389 __PACKAGE__->___debug( "Can '$method' -- provided by package" );
390 return $self->UNIVERSAL::can($method);
393 ### it's an accessor we provide;
394 if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) {
395 __PACKAGE__->___debug( "Can '$method' -- provided by object" );
396 return sub { $self->$method(@_); }
399 ### we don't support it
400 __PACKAGE__->___debug( "Cannot '$method'" );
404 ### don't autoload this
407 ### use autoload so we can have per-object accessors,
408 ### not per class, as that is incorrect
411 my($method) = ($AUTOLOAD =~ /([^:']+$)/);
413 my $val = $self->___autoload( $method, @_ ) or return;
421 my $assign = scalar @_; # is this an assignment?
423 ### a method on our object
424 if( UNIVERSAL::isa( $self, 'HASH' ) ) {
425 if ( not exists $self->{$method} ) {
426 __PACKAGE__->___error("No such accessor '$method'", 1);
430 ### a method on something else, die with a descriptive error;
433 __PACKAGE__->___error(
434 "You called '$AUTOLOAD' on '$self' which was interpreted by ".
435 __PACKAGE__ . " as an object call. Did you mean to include ".
436 "'$method' from somewhere else?", 1 );
440 my $val = $assign ? shift(@_) : $self->___get( $method );
446 if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
448 ### tie the reference, so we get an object and
449 ### we can use it's going out of scope to restore
451 my $cur = $self->{$method}->[VALUE];
453 tie ${$_[0]}, __PACKAGE__ . '::TIE',
454 sub { $self->$method( $cur ) };
459 __PACKAGE__->___error(
460 "Can not bind '$method' to anything but a SCALAR", 1
465 ### need to check the value?
466 if( exists $self->{$method}->[ALLOW] ) {
468 ### double assignment due to 'used only once' warnings
469 local $Params::Check::VERBOSE = 0;
470 local $Params::Check::VERBOSE = 0;
472 allow( $val, $self->{$method}->[ALLOW] ) or (
473 __PACKAGE__->___error(
474 "'$val' is an invalid value for '$method'", 1),
481 if( my $sub = $self->___callback ) {
482 $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
484 ### register the error
485 $self->___error( $@, 1 ), return if $@;
488 ### now we can actually assign it
490 $self->___set( $method, $val ) or return;
496 =head2 $val = $self->___get( METHOD_NAME );
498 Method to directly access the value of the given accessor in the
499 object. It circumvents all calls to allow checks, callbakcs, etc.
501 Use only if you C<Know What You Are Doing>! General usage for
502 this functionality would be in your own custom callbacks.
506 ### XXX O::A::lvalue is mirroring this behaviour! if this
507 ### changes, lvalue's autoload must be changed as well
510 my $method = shift or return;
511 return $self->{$method}->[VALUE];
514 =head2 $bool = $self->___set( METHOD_NAME => VALUE );
516 Method to directly set the value of the given accessor in the
517 object. It circumvents all calls to allow checks, callbakcs, etc.
519 Use only if you C<Know What You Are Doing>! General usage for
520 this functionality would be in your own custom callbacks.
526 my $method = shift or return;
528 ### you didn't give us a value to set!
529 exists $_[0] or return;
532 ### if there's more arguments than $self, then
533 ### replace the method called by the accessor.
534 ### XXX implement rw vs ro accessors!
535 $self->{$method}->[VALUE] = $val;
541 return unless $DEBUG;
545 my $lvl = shift || 0;
547 local $Carp::CarpLevel += 1;
555 my $lvl = shift || 0;
556 local $Carp::CarpLevel += ($lvl + 1);
557 $FATAL ? croak($msg) : carp($msg);
560 ### objects might be overloaded.. if so, we can't trust what "$self"
561 ### will return, which might get *really* painful.. so check for that
562 ### and get their unoverloaded stringval if needed.
567 my $mem = overload::Overloaded( $self )
568 ? overload::StrVal( $self )
571 $self->{$mem} = $sub if $sub;
573 return $self->{$mem};
576 =head1 LVALUE ACCESSORS
578 C<Object::Accessor> supports C<lvalue> attributes as well. To enable
579 these, you should create your objects in the designated namespace,
580 C<Object::Accessor::Lvalue>. For example:
582 my $obj = Object::Accessor::Lvalue->new('foo');
586 will actually print C<1> and work as expected. Since this is an
587 optional feature, that's not desirable in all cases, we require
588 you to explicitly use the C<Object::Accessor::Lvalue> class.
590 Doing the same on the standard C<Object>>Accessor> class would
591 generate the following code & errors:
593 my $obj = Object::Accessor->new('foo');
596 Can't modify non-lvalue subroutine call
598 Note that C<lvalue> support on C<AUTOLOAD> routines is a
599 C<perl 5.8.x> feature. See perldoc L<perl58delta> for details.
605 =item * Allow handlers
607 Due to the nature of C<lvalue subs>, we never get access to the
608 value you are assigning, so we can not check it againt your allow
609 handler. Allow handlers are therefor unsupported under C<lvalue>
612 See C<perldoc perlsub> for details.
616 Due to the nature of C<lvalue subs>, we never get access to the
617 value you are assigning, so we can not check provide this value
618 to your callback. Furthermore, we can not distinguish between
619 a C<get> and a C<set> call. Callbacks are therefor unsupported
620 under C<lvalue> conditions.
622 See C<perldoc perlsub> for details.
627 { package Object::Accessor::Lvalue;
628 use base 'Object::Accessor';
630 use vars qw[$AUTOLOAD];
632 ### constants needed to access values from the objects
633 *VALUE = *Object::Accessor::VALUE;
634 *ALLOW = *Object::Accessor::ALLOW;
636 ### largely copied from O::A::Autoload
637 sub AUTOLOAD : lvalue {
639 my($method) = ($AUTOLOAD =~ /([^:']+$)/);
641 $self->___autoload( $method, @_ ) or return;
643 ### *dont* add return to it, or it won't be stored
644 ### see perldoc perlsub on lvalue subs
645 ### XXX can't use $self->___get( ... ), as we MUST have
646 ### the container that's used for the lvalue assign as
647 ### the last statement... :(
648 $self->{$method}->[ VALUE() ];
653 my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
656 "Allow handlers are not supported for '". __PACKAGE__ ."' objects"
659 return $self->SUPER::mk_accessors( @_ );
662 sub register_callback {
665 "Callbacks are not supported for '". __PACKAGE__ ."' objects"
672 ### standard tie class for bound attributes
673 { package Object::Accessor::TIE;
676 use base 'Tie::StdScalar';
684 my $obj = bless \$ref, $class;
686 ### store the restore sub
687 $local{ $obj } = $sub;
693 my $sub = delete $local{ $tied };
695 ### run the restore sub to set the old value back
700 =head1 GLOBAL VARIABLES
702 =head2 $Object::Accessor::FATAL
704 Set this variable to true to make all attempted access to non-existant
706 This defaults to C<false>.
708 =head2 $Object::Accessor::DEBUG
710 Set this variable to enable debugging output.
711 This defaults to C<false>.
715 =head2 Create read-only accessors
717 Currently all accessors are read/write for everyone. Perhaps a future
718 release should make it possible to have read-only accessors as well.
722 If you use codereferences for your allow handlers, you will not be able
723 to freeze the data structures using C<Storable>.
725 Due to a bug in storable (until at least version 2.15), C<qr//> compiled
726 regexes also don't de-serialize properly. Although this bug has been
727 reported, you should be aware of this issue when serializing your objects.
729 You can track the bug here:
731 http://rt.cpan.org/Ticket/Display.html?id=1827
736 Jos Boumans E<lt>kane@cpan.orgE<gt>.
741 copyright (c) 2004-2005 Jos Boumans E<lt>kane@cpan.orgE<gt>.
744 This library is free software;
745 you may redistribute and/or modify it under the same
746 terms as Perl itself.