This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated Object-Accessor to CPAN version 0.44
[perl5.git] / cpan / Object-Accessor / lib / Object / Accessor.pm
CommitLineData
0bbb0bd4
JB
1package Object::Accessor;
2
3use strict;
4use Carp qw[carp croak];
5use vars qw[$FATAL $DEBUG $AUTOLOAD $VERSION];
6use Params::Check qw[allow];
0bbb0bd4
JB
7
8### some objects might have overload enabled, we'll need to
9### disable string overloading for callbacks
10require overload;
11
83f18a67 12$VERSION = '0.44';
0bbb0bd4
JB
13$FATAL = 0;
14$DEBUG = 0;
15
16use constant VALUE => 0; # array index in the hash value
17use constant ALLOW => 1; # array index in the hash value
1eea129c 18use constant ALIAS => 2; # array index in the hash value
0bbb0bd4
JB
19
20=head1 NAME
21
89a1beee 22Object::Accessor - interface to create per object accessors
0bbb0bd4
JB
23
24=head1 SYNOPSIS
25
26 ### using the object
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
31
32 $bool = $obj->mk_accessors('foo'); # create accessors
33 $bool = $obj->mk_accessors( # create accessors with input
34 {foo => ALLOW_HANDLER} ); # validation
1eea129c
SP
35
36 $bool = $obj->mk_aliases( # create an alias to an existing
37 alias_name => 'method'); # method name
e528b607 38
0bbb0bd4
JB
39 $clone = $obj->mk_clone; # create a clone of original
40 # object without data
41 $bool = $obj->mk_flush; # clean out all data
42
43 @list = $obj->ls_accessors; # retrieves a list of all
44 # accessors for this object
45
46 $bar = $obj->foo('bar'); # set 'foo' to 'bar'
47 $bar = $obj->foo(); # retrieve 'bar' again
48
49 $sub = $obj->can('foo'); # retrieve coderef for
50 # 'foo' accessor
51 $bar = $sub->('bar'); # set 'foo' via coderef
52 $bar = $sub->(); # retrieve 'bar' by coderef
53
54 ### using the object as base class
55 package My::Class;
56 use base 'Object::Accessor';
57
58 $obj = My::Class->new; # create base object
59 $bool = $obj->mk_accessors('foo'); # create accessors, etc...
60
be75734f 61 ### make all attempted access to non-existent accessors fatal
0bbb0bd4
JB
62 ### (defaults to false)
63 $Object::Accessor::FATAL = 1;
64
65 ### enable debugging
66 $Object::Accessor::DEBUG = 1;
67
68 ### advanced usage -- callbacks
69 { my $obj = Object::Accessor->new('foo');
70 $obj->register_callback( sub { ... } );
e528b607 71
0bbb0bd4 72 $obj->foo( 1 ); # these calls invoke the callback you registered
e528b607 73 $obj->foo() # which allows you to change the get/set
0bbb0bd4 74 # behaviour and what is returned to the caller.
e528b607 75 }
0bbb0bd4
JB
76
77 ### advanced usage -- lvalue attributes
78 { my $obj = Object::Accessor::Lvalue->new('foo');
79 print $obj->foo = 1; # will print 1
80 }
81
82 ### advanced usage -- scoped attribute values
83 { my $obj = Object::Accessor->new('foo');
e528b607 84
0bbb0bd4
JB
85 $obj->foo( 1 );
86 print $obj->foo; # will print 1
87
88 ### bind the scope of the value of attribute 'foo'
e528b607 89 ### to the scope of '$x' -- when $x goes out of
0bbb0bd4
JB
90 ### scope, 'foo's previous value will be restored
91 { $obj->foo( 2 => \my $x );
92 print $obj->foo, ' ', $x; # will print '2 2'
93 }
94 print $obj->foo; # will print 1
95 }
96
97
98=head1 DESCRIPTION
99
100C<Object::Accessor> provides an interface to create per object
101accessors (as opposed to per C<Class> accessors, as, for example,
102C<Class::Accessor> provides).
103
104You can choose to either subclass this module, and thus using its
105accessors on your own module, or to store an C<Object::Accessor>
106object inside your own object, and access the accessors from there.
107See the C<SYNOPSIS> for examples.
108
109=head1 METHODS
110
111=head2 $object = Object::Accessor->new( [ARGS] );
112
113Creates a new (and empty) C<Object::Accessor> object. This method is
114inheritable.
115
116Any arguments given to C<new> are passed straight to C<mk_accessors>.
117
118If you want to be able to assign to your accessors as if they
e528b607 119were C<lvalue>s, you should create your object in the
be75734f 120C<Object::Accessor::Lvalue> namespace instead. See the section
0bbb0bd4
JB
121on C<LVALUE ACCESSORS> below.
122
123=cut
124
125sub new {
126 my $class = shift;
127 my $obj = bless {}, $class;
e528b607 128
0bbb0bd4 129 $obj->mk_accessors( @_ ) if @_;
e528b607 130
0bbb0bd4
JB
131 return $obj;
132}
133
134=head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP );
135
136Creates a list of accessors for this object (and C<NOT> for other ones
137in the same class!).
138Will not clobber existing data, so if an accessor already exists,
139requesting to create again is effectively a C<no-op>.
140
141When providing a C<hashref> as argument, rather than a normal list,
142you can specify a list of key/value pairs of accessors and their
143respective input validators. The validators can be anything that
144C<Params::Check>'s C<allow> function accepts. Please see its manpage
145for details.
146
147For example:
148
149 $object->mk_accessors( {
150 foo => qr/^\d+$/, # digits only
151 bar => [0,1], # booleans
152 zot => \&my_sub # a custom verification sub
e528b607 153 } );
0bbb0bd4
JB
154
155Returns true on success, false on failure.
156
157Accessors that are called on an object, that do not exist return
158C<undef> by default, but you can make this a fatal error by setting the
159global variable C<$FATAL> to true. See the section on C<GLOBAL
160VARIABLES> for details.
161
162Note that you can bind the values of attributes to a scope. This allows
e528b607 163you to C<temporarily> change a value of an attribute, and have it's
0bbb0bd4
JB
164original value restored up on the end of it's bound variable's scope;
165
e528b607
CBW
166For example, in this snippet of code, the attribute C<foo> will
167temporarily be set to C<2>, until the end of the scope of C<$x>, at
0bbb0bd4
JB
168which point the original value of C<1> will be restored.
169
170 my $obj = Object::Accessor->new;
e528b607 171
0bbb0bd4
JB
172 $obj->mk_accessors('foo');
173 $obj->foo( 1 );
174 print $obj->foo; # will print 1
175
176 ### bind the scope of the value of attribute 'foo'
e528b607 177 ### to the scope of '$x' -- when $x goes out of
0bbb0bd4
JB
178 ### scope, 'foo' previous value will be restored
179 { $obj->foo( 2 => \my $x );
180 print $obj->foo, ' ', $x; # will print '2 2'
181 }
182 print $obj->foo; # will print 1
e528b607 183
0bbb0bd4
JB
184
185Note that all accessors are read/write for everyone. See the C<TODO>
186section for details.
187
188=cut
189
190sub mk_accessors {
191 my $self = $_[0];
192 my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' );
e528b607 193
0bbb0bd4
JB
194 ### first argument is a hashref, which means key/val pairs
195 ### as keys + allow handlers
196 for my $acc ( $is_hash ? keys %{$_[1]} : @_[1..$#_] ) {
e528b607 197
0bbb0bd4
JB
198 ### already created apparently
199 if( exists $self->{$acc} ) {
200 __PACKAGE__->___debug( "Accessor '$acc' already exists");
201 next;
202 }
203
204 __PACKAGE__->___debug( "Creating accessor '$acc'");
205
206 ### explicitly vivify it, so that exists works in ls_accessors()
207 $self->{$acc}->[VALUE] = undef;
e528b607 208
0bbb0bd4
JB
209 ### set the allow handler only if one was specified
210 $self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash;
211 }
212
213 return 1;
214}
215
216=head2 @list = $self->ls_accessors;
217
218Returns a list of accessors that are supported by the current object.
219The corresponding coderefs can be retrieved by passing this list one
220by one to the C<can> method.
221
222=cut
223
224sub ls_accessors {
e528b607 225 ### metainformation is stored in the stringified
0bbb0bd4
JB
226 ### key of the object, so skip that when listing accessors
227 return sort grep { $_ ne "$_[0]" } keys %{$_[0]};
228}
229
230=head2 $ref = $self->ls_allow(KEY)
231
232Returns the allow handler for the given key, which can be used with
233C<Params::Check>'s C<allow()> handler. If there was no allow handler
234specified, an allow handler that always returns true will be returned.
235
236=cut
237
238sub ls_allow {
239 my $self = shift;
240 my $key = shift or return;
241 return exists $self->{$key}->[ALLOW]
e528b607 242 ? $self->{$key}->[ALLOW]
0bbb0bd4
JB
243 : sub { 1 };
244}
245
1eea129c
SP
246=head2 $bool = $self->mk_aliases( alias => method, [alias2 => method2, ...] );
247
248Creates an alias for a given method name. For all intents and purposes,
249these two accessors are now identical for this object. This is akin to
250doing the following on the symbol table level:
251
252 *alias = *method
253
254This allows you to do the following:
255
256 $self->mk_accessors('foo');
257 $self->mk_aliases( bar => 'foo' );
e528b607 258
1eea129c
SP
259 $self->bar( 42 );
260 print $self->foo; # will print 42
261
262=cut
263
264sub mk_aliases {
265 my $self = shift;
266 my %aliases = @_;
e528b607 267
1eea129c
SP
268 while( my($alias, $method) = each %aliases ) {
269
270 ### already created apparently
271 if( exists $self->{$alias} ) {
272 __PACKAGE__->___debug( "Accessor '$alias' already exists");
273 next;
274 }
275
276 $self->___alias( $alias => $method );
277 }
278
279 return 1;
280}
281
0bbb0bd4
JB
282=head2 $clone = $self->mk_clone;
283
284Makes a clone of the current object, which will have the exact same
285accessors as the current object, but without the data stored in them.
286
287=cut
288
289### XXX this creates an object WITH allow handlers at all times.
290### even if the original didnt
291sub mk_clone {
292 my $self = $_[0];
293 my $class = ref $self;
294
295 my $clone = $class->new;
e528b607 296
0bbb0bd4
JB
297 ### split out accessors with and without allow handlers, so we
298 ### don't install dummy allow handers (which makes O::A::lvalue
1eea129c 299 ### warn for example)
0bbb0bd4
JB
300 my %hash; my @list;
301 for my $acc ( $self->ls_accessors ) {
302 my $allow = $self->{$acc}->[ALLOW];
303 $allow ? $hash{$acc} = $allow : push @list, $acc;
1eea129c
SP
304
305 ### is this an alias?
306 if( my $org = $self->{ $acc }->[ ALIAS ] ) {
307 $clone->___alias( $acc => $org );
308 }
0bbb0bd4
JB
309 }
310
311 ### copy the accessors from $self to $clone
312 $clone->mk_accessors( \%hash ) if %hash;
313 $clone->mk_accessors( @list ) if @list;
314
315 ### copy callbacks
316 #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
317 $clone->___callback( $self->___callback );
318
319 return $clone;
320}
321
322=head2 $bool = $self->mk_flush;
323
324Flushes all the data from the current object; all accessors will be
325set back to their default state of C<undef>.
326
327Returns true on success and false on failure.
328
329=cut
330
331sub mk_flush {
332 my $self = $_[0];
333
334 # set each accessor's data to undef
335 $self->{$_}->[VALUE] = undef for $self->ls_accessors;
336
337 return 1;
338}
339
340=head2 $bool = $self->mk_verify;
341
342Checks if all values in the current object are in accordance with their
343own allow handler. Specifically useful to check if an empty initialised
344object has been filled with values satisfying their own allow criteria.
345
346=cut
347
348sub mk_verify {
349 my $self = $_[0];
e528b607 350
0bbb0bd4
JB
351 my $fail;
352 for my $name ( $self->ls_accessors ) {
353 unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
354 my $val = defined $self->$name ? $self->$name : '<undef>';
355
356 __PACKAGE__->___error("'$name' ($val) is invalid");
357 $fail++;
358 }
359 }
360
361 return if $fail;
362 return 1;
e528b607 363}
0bbb0bd4
JB
364
365=head2 $bool = $self->register_callback( sub { ... } );
366
367This method allows you to register a callback, that is invoked
368every time an accessor is called. This allows you to munge input
369data, access external data stores, etc.
370
371You are free to return whatever you wish. On a C<set> call, the
372data is even stored in the object.
373
374Below is an example of the use of a callback.
e528b607 375
0bbb0bd4 376 $object->some_method( "some_value" );
e528b607 377
0bbb0bd4
JB
378 my $callback = sub {
379 my $self = shift; # the object
380 my $meth = shift; # "some_method"
e528b607 381 my $val = shift; # ["some_value"]
0bbb0bd4
JB
382 # could be undef -- check 'exists';
383 # if scalar @$val is empty, it was a 'get'
e528b607 384
0bbb0bd4
JB
385 # your code here
386
387 return $new_val; # the value you want to be set/returned
e528b607 388 }
0bbb0bd4
JB
389
390To access the values stored in the object, circumventing the
391callback structure, you should use the C<___get> and C<___set> methods
e528b607 392documented further down.
0bbb0bd4
JB
393
394=cut
395
396sub register_callback {
397 my $self = shift;
398 my $sub = shift or return;
e528b607 399
0bbb0bd4
JB
400 ### use the memory address as key, it's not used EVER as an
401 ### accessor --kane
402 $self->___callback( $sub );
403
404 return 1;
405}
406
407
408=head2 $bool = $self->can( METHOD_NAME )
409
410This method overrides C<UNIVERAL::can> in order to provide coderefs to
411accessors which are loaded on demand. It will behave just like
412C<UNIVERSAL::can> where it can -- returning a class method if it exists,
413or a closure pointing to a valid accessor of this particular object.
414
415You can use it as follows:
416
417 $sub = $object->can('some_accessor'); # retrieve the coderef
418 $sub->('foo'); # 'some_accessor' now set
419 # to 'foo' for $object
420 $foo = $sub->(); # retrieve the contents
421 # of 'some_accessor'
422
423See the C<SYNOPSIS> for more examples.
424
425=cut
426
427### custom 'can' as UNIVERSAL::can ignores autoload
428sub can {
429 my($self, $method) = @_;
430
431 ### it's one of our regular methods
83f18a67
CBW
432 my $code = $self->UNIVERSAL::can($method);
433 if( $code ) {
434 carp( "Can '$method' -- provided by package" ) if $DEBUG;
435 return $code;
0bbb0bd4
JB
436 }
437
438 ### it's an accessor we provide;
439 if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) {
83f18a67 440 carp( "Can '$method' -- provided by object" ) if $DEBUG;
0bbb0bd4
JB
441 return sub { $self->$method(@_); }
442 }
443
444 ### we don't support it
83f18a67 445 carp( "Cannot '$method'" ) if $DEBUG;
0bbb0bd4
JB
446 return;
447}
448
449### don't autoload this
450sub DESTROY { 1 };
451
452### use autoload so we can have per-object accessors,
453### not per class, as that is incorrect
454sub AUTOLOAD {
455 my $self = shift;
456 my($method) = ($AUTOLOAD =~ /([^:']+$)/);
457
458 my $val = $self->___autoload( $method, @_ ) or return;
459
460 return $val->[0];
461}
462
463sub ___autoload {
464 my $self = shift;
465 my $method = shift;
466 my $assign = scalar @_; # is this an assignment?
467
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);
472 return;
e528b607
CBW
473 }
474
0bbb0bd4 475 ### a method on something else, die with a descriptive error;
e528b607 476 } else {
0bbb0bd4 477 local $FATAL = 1;
e528b607 478 __PACKAGE__->___error(
0bbb0bd4
JB
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 );
e528b607 482 }
0bbb0bd4 483
1eea129c
SP
484 ### is this is an alias, redispatch to the original method
485 if( my $original = $self->{ $method }->[ALIAS] ) {
486 return $self->___autoload( $original, @_ );
e528b607 487 }
1eea129c 488
0bbb0bd4
JB
489 ### assign?
490 my $val = $assign ? shift(@_) : $self->___get( $method );
491
492 if( $assign ) {
493
494 ### any binding?
495 if( $_[0] ) {
496 if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
e528b607 497
0bbb0bd4
JB
498 ### tie the reference, so we get an object and
499 ### we can use it's going out of scope to restore
500 ### the old value
501 my $cur = $self->{$method}->[VALUE];
e528b607
CBW
502
503 tie ${$_[0]}, __PACKAGE__ . '::TIE',
0bbb0bd4 504 sub { $self->$method( $cur ) };
e528b607 505
0bbb0bd4 506 ${$_[0]} = $val;
e528b607 507
0bbb0bd4 508 } else {
e528b607
CBW
509 __PACKAGE__->___error(
510 "Can not bind '$method' to anything but a SCALAR", 1
0bbb0bd4
JB
511 );
512 }
513 }
e528b607 514
0bbb0bd4 515 ### need to check the value?
e528b607 516 if( defined $self->{$method}->[ALLOW] ) {
0bbb0bd4
JB
517
518 ### double assignment due to 'used only once' warnings
519 local $Params::Check::VERBOSE = 0;
520 local $Params::Check::VERBOSE = 0;
e528b607 521
0bbb0bd4 522 allow( $val, $self->{$method}->[ALLOW] ) or (
e528b607
CBW
523 __PACKAGE__->___error(
524 "'$val' is an invalid value for '$method'", 1),
525 return
526 );
0bbb0bd4
JB
527 }
528 }
e528b607 529
0bbb0bd4
JB
530 ### callbacks?
531 if( my $sub = $self->___callback ) {
532 $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
e528b607 533
0bbb0bd4
JB
534 ### register the error
535 $self->___error( $@, 1 ), return if $@;
536 }
537
538 ### now we can actually assign it
539 if( $assign ) {
540 $self->___set( $method, $val ) or return;
541 }
e528b607 542
0bbb0bd4
JB
543 return [$val];
544}
545
546=head2 $val = $self->___get( METHOD_NAME );
547
548Method to directly access the value of the given accessor in the
be75734f 549object. It circumvents all calls to allow checks, callbacks, etc.
0bbb0bd4 550
e528b607 551Use only if you C<Know What You Are Doing>! General usage for
0bbb0bd4
JB
552this functionality would be in your own custom callbacks.
553
554=cut
555
556### XXX O::A::lvalue is mirroring this behaviour! if this
557### changes, lvalue's autoload must be changed as well
558sub ___get {
559 my $self = shift;
560 my $method = shift or return;
561 return $self->{$method}->[VALUE];
562}
563
564=head2 $bool = $self->___set( METHOD_NAME => VALUE );
565
566Method to directly set the value of the given accessor in the
be75734f 567object. It circumvents all calls to allow checks, callbacks, etc.
0bbb0bd4 568
e528b607 569Use only if you C<Know What You Are Doing>! General usage for
0bbb0bd4
JB
570this functionality would be in your own custom callbacks.
571
e528b607 572=cut
0bbb0bd4
JB
573
574sub ___set {
575 my $self = shift;
576 my $method = shift or return;
e528b607 577
0bbb0bd4 578 ### you didn't give us a value to set!
e528b607 579 @_ or return;
0bbb0bd4 580 my $val = shift;
e528b607 581
0bbb0bd4
JB
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;
586
587 return 1;
588}
589
1eea129c
SP
590=head2 $bool = $self->___alias( ALIAS => METHOD );
591
592Method to directly alias one accessor to another for
593this object. It circumvents all sanity checks, etc.
594
e528b607 595Use only if you C<Know What You Are Doing>!
1eea129c
SP
596
597=cut
598
599sub ___alias {
600 my $self = shift;
601 my $alias = shift or return;
602 my $method = shift or return;
e528b607 603
1eea129c 604 $self->{ $alias }->[ALIAS] = $method;
e528b607 605
1eea129c
SP
606 return 1;
607}
608
0bbb0bd4
JB
609sub ___debug {
610 return unless $DEBUG;
611
612 my $self = shift;
613 my $msg = shift;
0bbb0bd4
JB
614
615 local $Carp::CarpLevel += 1;
e528b607 616
0bbb0bd4
JB
617 carp($msg);
618}
619
620sub ___error {
621 my $self = shift;
622 my $msg = shift;
623 my $lvl = shift || 0;
624 local $Carp::CarpLevel += ($lvl + 1);
625 $FATAL ? croak($msg) : carp($msg);
626}
627
628### objects might be overloaded.. if so, we can't trust what "$self"
629### will return, which might get *really* painful.. so check for that
630### and get their unoverloaded stringval if needed.
631sub ___callback {
632 my $self = shift;
633 my $sub = shift;
e528b607 634
0bbb0bd4
JB
635 my $mem = overload::Overloaded( $self )
636 ? overload::StrVal( $self )
637 : "$self";
638
639 $self->{$mem} = $sub if $sub;
e528b607 640
0bbb0bd4
JB
641 return $self->{$mem};
642}
643
644=head1 LVALUE ACCESSORS
645
646C<Object::Accessor> supports C<lvalue> attributes as well. To enable
647these, you should create your objects in the designated namespace,
648C<Object::Accessor::Lvalue>. For example:
649
650 my $obj = Object::Accessor::Lvalue->new('foo');
651 $obj->foo += 1;
652 print $obj->foo;
e528b607 653
0bbb0bd4
JB
654will actually print C<1> and work as expected. Since this is an
655optional feature, that's not desirable in all cases, we require
656you to explicitly use the C<Object::Accessor::Lvalue> class.
657
658Doing the same on the standard C<Object>>Accessor> class would
659generate the following code & errors:
660
661 my $obj = Object::Accessor->new('foo');
662 $obj->foo += 1;
663
664 Can't modify non-lvalue subroutine call
665
666Note that C<lvalue> support on C<AUTOLOAD> routines is a
667C<perl 5.8.x> feature. See perldoc L<perl58delta> for details.
668
669=head2 CAVEATS
670
671=over 4
672
673=item * Allow handlers
674
675Due to the nature of C<lvalue subs>, we never get access to the
be75734f 676value you are assigning, so we can not check it against your allow
0bbb0bd4
JB
677handler. Allow handlers are therefor unsupported under C<lvalue>
678conditions.
679
680See C<perldoc perlsub> for details.
681
682=item * Callbacks
683
684Due to the nature of C<lvalue subs>, we never get access to the
685value you are assigning, so we can not check provide this value
686to your callback. Furthermore, we can not distinguish between
e528b607 687a C<get> and a C<set> call. Callbacks are therefor unsupported
0bbb0bd4
JB
688under C<lvalue> conditions.
689
690See C<perldoc perlsub> for details.
691
692
693=cut
694
695{ package Object::Accessor::Lvalue;
696 use base 'Object::Accessor';
697 use strict;
698 use vars qw[$AUTOLOAD];
699
700 ### constants needed to access values from the objects
701 *VALUE = *Object::Accessor::VALUE;
702 *ALLOW = *Object::Accessor::ALLOW;
703
e528b607 704 ### largely copied from O::A::Autoload
0bbb0bd4
JB
705 sub AUTOLOAD : lvalue {
706 my $self = shift;
707 my($method) = ($AUTOLOAD =~ /([^:']+$)/);
708
709 $self->___autoload( $method, @_ ) or return;
710
711 ### *dont* add return to it, or it won't be stored
712 ### see perldoc perlsub on lvalue subs
713 ### XXX can't use $self->___get( ... ), as we MUST have
714 ### the container that's used for the lvalue assign as
715 ### the last statement... :(
716 $self->{$method}->[ VALUE() ];
717 }
718
719 sub mk_accessors {
720 my $self = shift;
721 my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
e528b607 722
0bbb0bd4
JB
723 $self->___error(
724 "Allow handlers are not supported for '". __PACKAGE__ ."' objects"
725 ) if $is_hash;
e528b607 726
0bbb0bd4 727 return $self->SUPER::mk_accessors( @_ );
e528b607
CBW
728 }
729
0bbb0bd4
JB
730 sub register_callback {
731 my $self = shift;
732 $self->___error(
733 "Callbacks are not supported for '". __PACKAGE__ ."' objects"
734 );
735 return;
e528b607
CBW
736 }
737}
0bbb0bd4
JB
738
739
740### standard tie class for bound attributes
741{ package Object::Accessor::TIE;
742 use Tie::Scalar;
0bbb0bd4
JB
743 use base 'Tie::StdScalar';
744
745 my %local = ();
746
747 sub TIESCALAR {
748 my $class = shift;
749 my $sub = shift;
750 my $ref = undef;
751 my $obj = bless \$ref, $class;
752
e528b607 753 ### store the restore sub
0bbb0bd4
JB
754 $local{ $obj } = $sub;
755 return $obj;
756 }
e528b607 757
0bbb0bd4
JB
758 sub DESTROY {
759 my $tied = shift;
760 my $sub = delete $local{ $tied };
761
762 ### run the restore sub to set the old value back
e528b607
CBW
763 return $sub->();
764 }
0bbb0bd4
JB
765}
766
1eea129c
SP
767=back
768
0bbb0bd4
JB
769=head1 GLOBAL VARIABLES
770
771=head2 $Object::Accessor::FATAL
772
be75734f 773Set this variable to true to make all attempted access to non-existent
0bbb0bd4
JB
774accessors be fatal.
775This defaults to C<false>.
776
777=head2 $Object::Accessor::DEBUG
778
779Set this variable to enable debugging output.
780This defaults to C<false>.
781
782=head1 TODO
783
784=head2 Create read-only accessors
785
786Currently all accessors are read/write for everyone. Perhaps a future
787release should make it possible to have read-only accessors as well.
788
789=head1 CAVEATS
790
791If you use codereferences for your allow handlers, you will not be able
792to freeze the data structures using C<Storable>.
793
e528b607
CBW
794Due to a bug in storable (until at least version 2.15), C<qr//> compiled
795regexes also don't de-serialize properly. Although this bug has been
0bbb0bd4
JB
796reported, you should be aware of this issue when serializing your objects.
797
e528b607 798You can track the bug here:
0bbb0bd4
JB
799
800 http://rt.cpan.org/Ticket/Display.html?id=1827
801
1eea129c
SP
802=head1 BUG REPORTS
803
804Please report bugs or other issues to E<lt>bug-object-accessor@rt.cpan.orgE<gt>.
805
0bbb0bd4
JB
806=head1 AUTHOR
807
1eea129c 808This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
0bbb0bd4
JB
809
810=head1 COPYRIGHT
811
e528b607 812This library is free software; you may redistribute and/or modify it
1eea129c 813under the same terms as Perl itself.
0bbb0bd4
JB
814
815=cut
816
8171;