Commit | Line | Data |
---|---|---|
0bbb0bd4 JB |
1 | package Object::Accessor; |
2 | ||
3 | use strict; | |
4 | use Carp qw[carp croak]; | |
5 | use vars qw[$FATAL $DEBUG $AUTOLOAD $VERSION]; | |
6 | use Params::Check qw[allow]; | |
7 | use Data::Dumper; | |
8 | ||
9 | ### some objects might have overload enabled, we'll need to | |
10 | ### disable string overloading for callbacks | |
11 | require overload; | |
12 | ||
13 | $VERSION = '0.32'; | |
14 | $FATAL = 0; | |
15 | $DEBUG = 0; | |
16 | ||
17 | use constant VALUE => 0; # array index in the hash value | |
18 | use constant ALLOW => 1; # array index in the hash value | |
19 | ||
20 | =head1 NAME | |
21 | ||
22 | Object::Accessor | |
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 | |
35 | ||
36 | $clone = $obj->mk_clone; # create a clone of original | |
37 | # object without data | |
38 | $bool = $obj->mk_flush; # clean out all data | |
39 | ||
40 | @list = $obj->ls_accessors; # retrieves a list of all | |
41 | # accessors for this object | |
42 | ||
43 | $bar = $obj->foo('bar'); # set 'foo' to 'bar' | |
44 | $bar = $obj->foo(); # retrieve 'bar' again | |
45 | ||
46 | $sub = $obj->can('foo'); # retrieve coderef for | |
47 | # 'foo' accessor | |
48 | $bar = $sub->('bar'); # set 'foo' via coderef | |
49 | $bar = $sub->(); # retrieve 'bar' by coderef | |
50 | ||
51 | ### using the object as base class | |
52 | package My::Class; | |
53 | use base 'Object::Accessor'; | |
54 | ||
55 | $obj = My::Class->new; # create base object | |
56 | $bool = $obj->mk_accessors('foo'); # create accessors, etc... | |
57 | ||
58 | ### make all attempted access to non-existant accessors fatal | |
59 | ### (defaults to false) | |
60 | $Object::Accessor::FATAL = 1; | |
61 | ||
62 | ### enable debugging | |
63 | $Object::Accessor::DEBUG = 1; | |
64 | ||
65 | ### advanced usage -- callbacks | |
66 | { my $obj = Object::Accessor->new('foo'); | |
67 | $obj->register_callback( sub { ... } ); | |
68 | ||
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. | |
72 | } | |
73 | ||
74 | ### advanced usage -- lvalue attributes | |
75 | { my $obj = Object::Accessor::Lvalue->new('foo'); | |
76 | print $obj->foo = 1; # will print 1 | |
77 | } | |
78 | ||
79 | ### advanced usage -- scoped attribute values | |
80 | { my $obj = Object::Accessor->new('foo'); | |
81 | ||
82 | $obj->foo( 1 ); | |
83 | print $obj->foo; # will print 1 | |
84 | ||
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' | |
90 | } | |
91 | print $obj->foo; # will print 1 | |
92 | } | |
93 | ||
94 | ||
95 | =head1 DESCRIPTION | |
96 | ||
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). | |
100 | ||
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. | |
105 | ||
106 | =head1 METHODS | |
107 | ||
108 | =head2 $object = Object::Accessor->new( [ARGS] ); | |
109 | ||
110 | Creates a new (and empty) C<Object::Accessor> object. This method is | |
111 | inheritable. | |
112 | ||
113 | Any arguments given to C<new> are passed straight to C<mk_accessors>. | |
114 | ||
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. | |
119 | ||
120 | =cut | |
121 | ||
122 | sub new { | |
123 | my $class = shift; | |
124 | my $obj = bless {}, $class; | |
125 | ||
126 | $obj->mk_accessors( @_ ) if @_; | |
127 | ||
128 | return $obj; | |
129 | } | |
130 | ||
131 | =head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP ); | |
132 | ||
133 | Creates a list of accessors for this object (and C<NOT> for other ones | |
134 | in the same class!). | |
135 | Will not clobber existing data, so if an accessor already exists, | |
136 | requesting to create again is effectively a C<no-op>. | |
137 | ||
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 | |
142 | for details. | |
143 | ||
144 | For example: | |
145 | ||
146 | $object->mk_accessors( { | |
147 | foo => qr/^\d+$/, # digits only | |
148 | bar => [0,1], # booleans | |
149 | zot => \&my_sub # a custom verification sub | |
150 | } ); | |
151 | ||
152 | Returns true on success, false on failure. | |
153 | ||
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. | |
158 | ||
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; | |
162 | ||
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. | |
166 | ||
167 | my $obj = Object::Accessor->new; | |
168 | ||
169 | $obj->mk_accessors('foo'); | |
170 | $obj->foo( 1 ); | |
171 | print $obj->foo; # will print 1 | |
172 | ||
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' | |
178 | } | |
179 | print $obj->foo; # will print 1 | |
180 | ||
181 | ||
182 | Note that all accessors are read/write for everyone. See the C<TODO> | |
183 | section for details. | |
184 | ||
185 | =cut | |
186 | ||
187 | sub mk_accessors { | |
188 | my $self = $_[0]; | |
189 | my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' ); | |
190 | ||
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..$#_] ) { | |
194 | ||
195 | ### already created apparently | |
196 | if( exists $self->{$acc} ) { | |
197 | __PACKAGE__->___debug( "Accessor '$acc' already exists"); | |
198 | next; | |
199 | } | |
200 | ||
201 | __PACKAGE__->___debug( "Creating accessor '$acc'"); | |
202 | ||
203 | ### explicitly vivify it, so that exists works in ls_accessors() | |
204 | $self->{$acc}->[VALUE] = undef; | |
205 | ||
206 | ### set the allow handler only if one was specified | |
207 | $self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash; | |
208 | } | |
209 | ||
210 | return 1; | |
211 | } | |
212 | ||
213 | =head2 @list = $self->ls_accessors; | |
214 | ||
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. | |
218 | ||
219 | =cut | |
220 | ||
221 | sub ls_accessors { | |
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]}; | |
225 | } | |
226 | ||
227 | =head2 $ref = $self->ls_allow(KEY) | |
228 | ||
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. | |
232 | ||
233 | =cut | |
234 | ||
235 | sub ls_allow { | |
236 | my $self = shift; | |
237 | my $key = shift or return; | |
238 | return exists $self->{$key}->[ALLOW] | |
239 | ? $self->{$key}->[ALLOW] | |
240 | : sub { 1 }; | |
241 | } | |
242 | ||
243 | =head2 $clone = $self->mk_clone; | |
244 | ||
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. | |
247 | ||
248 | =cut | |
249 | ||
250 | ### XXX this creates an object WITH allow handlers at all times. | |
251 | ### even if the original didnt | |
252 | sub mk_clone { | |
253 | my $self = $_[0]; | |
254 | my $class = ref $self; | |
255 | ||
256 | my $clone = $class->new; | |
257 | ||
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) | |
261 | my %hash; my @list; | |
262 | for my $acc ( $self->ls_accessors ) { | |
263 | my $allow = $self->{$acc}->[ALLOW]; | |
264 | $allow ? $hash{$acc} = $allow : push @list, $acc; | |
265 | } | |
266 | ||
267 | ### copy the accessors from $self to $clone | |
268 | $clone->mk_accessors( \%hash ) if %hash; | |
269 | $clone->mk_accessors( @list ) if @list; | |
270 | ||
271 | ### copy callbacks | |
272 | #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"}; | |
273 | $clone->___callback( $self->___callback ); | |
274 | ||
275 | return $clone; | |
276 | } | |
277 | ||
278 | =head2 $bool = $self->mk_flush; | |
279 | ||
280 | Flushes all the data from the current object; all accessors will be | |
281 | set back to their default state of C<undef>. | |
282 | ||
283 | Returns true on success and false on failure. | |
284 | ||
285 | =cut | |
286 | ||
287 | sub mk_flush { | |
288 | my $self = $_[0]; | |
289 | ||
290 | # set each accessor's data to undef | |
291 | $self->{$_}->[VALUE] = undef for $self->ls_accessors; | |
292 | ||
293 | return 1; | |
294 | } | |
295 | ||
296 | =head2 $bool = $self->mk_verify; | |
297 | ||
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. | |
301 | ||
302 | =cut | |
303 | ||
304 | sub mk_verify { | |
305 | my $self = $_[0]; | |
306 | ||
307 | my $fail; | |
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>'; | |
311 | ||
312 | __PACKAGE__->___error("'$name' ($val) is invalid"); | |
313 | $fail++; | |
314 | } | |
315 | } | |
316 | ||
317 | return if $fail; | |
318 | return 1; | |
319 | } | |
320 | ||
321 | =head2 $bool = $self->register_callback( sub { ... } ); | |
322 | ||
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. | |
326 | ||
327 | You are free to return whatever you wish. On a C<set> call, the | |
328 | data is even stored in the object. | |
329 | ||
330 | Below is an example of the use of a callback. | |
331 | ||
332 | $object->some_method( "some_value" ); | |
333 | ||
334 | my $callback = sub { | |
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' | |
340 | ||
341 | # your code here | |
342 | ||
343 | return $new_val; # the value you want to be set/returned | |
344 | } | |
345 | ||
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. | |
349 | ||
350 | =cut | |
351 | ||
352 | sub register_callback { | |
353 | my $self = shift; | |
354 | my $sub = shift or return; | |
355 | ||
356 | ### use the memory address as key, it's not used EVER as an | |
357 | ### accessor --kane | |
358 | $self->___callback( $sub ); | |
359 | ||
360 | return 1; | |
361 | } | |
362 | ||
363 | ||
364 | =head2 $bool = $self->can( METHOD_NAME ) | |
365 | ||
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. | |
370 | ||
371 | You can use it as follows: | |
372 | ||
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 | |
377 | # of 'some_accessor' | |
378 | ||
379 | See the C<SYNOPSIS> for more examples. | |
380 | ||
381 | =cut | |
382 | ||
383 | ### custom 'can' as UNIVERSAL::can ignores autoload | |
384 | sub can { | |
385 | my($self, $method) = @_; | |
386 | ||
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); | |
391 | } | |
392 | ||
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(@_); } | |
397 | } | |
398 | ||
399 | ### we don't support it | |
400 | __PACKAGE__->___debug( "Cannot '$method'" ); | |
401 | return; | |
402 | } | |
403 | ||
404 | ### don't autoload this | |
405 | sub DESTROY { 1 }; | |
406 | ||
407 | ### use autoload so we can have per-object accessors, | |
408 | ### not per class, as that is incorrect | |
409 | sub AUTOLOAD { | |
410 | my $self = shift; | |
411 | my($method) = ($AUTOLOAD =~ /([^:']+$)/); | |
412 | ||
413 | my $val = $self->___autoload( $method, @_ ) or return; | |
414 | ||
415 | return $val->[0]; | |
416 | } | |
417 | ||
418 | sub ___autoload { | |
419 | my $self = shift; | |
420 | my $method = shift; | |
421 | my $assign = scalar @_; # is this an assignment? | |
422 | ||
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); | |
427 | return; | |
428 | } | |
429 | ||
430 | ### a method on something else, die with a descriptive error; | |
431 | } else { | |
432 | local $FATAL = 1; | |
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 ); | |
437 | } | |
438 | ||
439 | ### assign? | |
440 | my $val = $assign ? shift(@_) : $self->___get( $method ); | |
441 | ||
442 | if( $assign ) { | |
443 | ||
444 | ### any binding? | |
445 | if( $_[0] ) { | |
446 | if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) { | |
447 | ||
448 | ### tie the reference, so we get an object and | |
449 | ### we can use it's going out of scope to restore | |
450 | ### the old value | |
451 | my $cur = $self->{$method}->[VALUE]; | |
452 | ||
453 | tie ${$_[0]}, __PACKAGE__ . '::TIE', | |
454 | sub { $self->$method( $cur ) }; | |
455 | ||
456 | ${$_[0]} = $val; | |
457 | ||
458 | } else { | |
459 | __PACKAGE__->___error( | |
460 | "Can not bind '$method' to anything but a SCALAR", 1 | |
461 | ); | |
462 | } | |
463 | } | |
464 | ||
465 | ### need to check the value? | |
466 | if( exists $self->{$method}->[ALLOW] ) { | |
467 | ||
468 | ### double assignment due to 'used only once' warnings | |
469 | local $Params::Check::VERBOSE = 0; | |
470 | local $Params::Check::VERBOSE = 0; | |
471 | ||
472 | allow( $val, $self->{$method}->[ALLOW] ) or ( | |
473 | __PACKAGE__->___error( | |
474 | "'$val' is an invalid value for '$method'", 1), | |
475 | return | |
476 | ); | |
477 | } | |
478 | } | |
479 | ||
480 | ### callbacks? | |
481 | if( my $sub = $self->___callback ) { | |
482 | $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) }; | |
483 | ||
484 | ### register the error | |
485 | $self->___error( $@, 1 ), return if $@; | |
486 | } | |
487 | ||
488 | ### now we can actually assign it | |
489 | if( $assign ) { | |
490 | $self->___set( $method, $val ) or return; | |
491 | } | |
492 | ||
493 | return [$val]; | |
494 | } | |
495 | ||
496 | =head2 $val = $self->___get( METHOD_NAME ); | |
497 | ||
498 | Method to directly access the value of the given accessor in the | |
499 | object. It circumvents all calls to allow checks, callbakcs, etc. | |
500 | ||
501 | Use only if you C<Know What You Are Doing>! General usage for | |
502 | this functionality would be in your own custom callbacks. | |
503 | ||
504 | =cut | |
505 | ||
506 | ### XXX O::A::lvalue is mirroring this behaviour! if this | |
507 | ### changes, lvalue's autoload must be changed as well | |
508 | sub ___get { | |
509 | my $self = shift; | |
510 | my $method = shift or return; | |
511 | return $self->{$method}->[VALUE]; | |
512 | } | |
513 | ||
514 | =head2 $bool = $self->___set( METHOD_NAME => VALUE ); | |
515 | ||
516 | Method to directly set the value of the given accessor in the | |
517 | object. It circumvents all calls to allow checks, callbakcs, etc. | |
518 | ||
519 | Use only if you C<Know What You Are Doing>! General usage for | |
520 | this functionality would be in your own custom callbacks. | |
521 | ||
522 | =cut | |
523 | ||
524 | sub ___set { | |
525 | my $self = shift; | |
526 | my $method = shift or return; | |
527 | ||
528 | ### you didn't give us a value to set! | |
529 | exists $_[0] or return; | |
530 | my $val = shift; | |
531 | ||
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; | |
536 | ||
537 | return 1; | |
538 | } | |
539 | ||
540 | sub ___debug { | |
541 | return unless $DEBUG; | |
542 | ||
543 | my $self = shift; | |
544 | my $msg = shift; | |
545 | my $lvl = shift || 0; | |
546 | ||
547 | local $Carp::CarpLevel += 1; | |
548 | ||
549 | carp($msg); | |
550 | } | |
551 | ||
552 | sub ___error { | |
553 | my $self = shift; | |
554 | my $msg = shift; | |
555 | my $lvl = shift || 0; | |
556 | local $Carp::CarpLevel += ($lvl + 1); | |
557 | $FATAL ? croak($msg) : carp($msg); | |
558 | } | |
559 | ||
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. | |
563 | sub ___callback { | |
564 | my $self = shift; | |
565 | my $sub = shift; | |
566 | ||
567 | my $mem = overload::Overloaded( $self ) | |
568 | ? overload::StrVal( $self ) | |
569 | : "$self"; | |
570 | ||
571 | $self->{$mem} = $sub if $sub; | |
572 | ||
573 | return $self->{$mem}; | |
574 | } | |
575 | ||
576 | =head1 LVALUE ACCESSORS | |
577 | ||
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: | |
581 | ||
582 | my $obj = Object::Accessor::Lvalue->new('foo'); | |
583 | $obj->foo += 1; | |
584 | print $obj->foo; | |
585 | ||
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. | |
589 | ||
590 | Doing the same on the standard C<Object>>Accessor> class would | |
591 | generate the following code & errors: | |
592 | ||
593 | my $obj = Object::Accessor->new('foo'); | |
594 | $obj->foo += 1; | |
595 | ||
596 | Can't modify non-lvalue subroutine call | |
597 | ||
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. | |
600 | ||
601 | =head2 CAVEATS | |
602 | ||
603 | =over 4 | |
604 | ||
605 | =item * Allow handlers | |
606 | ||
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> | |
610 | conditions. | |
611 | ||
612 | See C<perldoc perlsub> for details. | |
613 | ||
614 | =item * Callbacks | |
615 | ||
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. | |
621 | ||
622 | See C<perldoc perlsub> for details. | |
623 | ||
624 | ||
625 | =cut | |
626 | ||
627 | { package Object::Accessor::Lvalue; | |
628 | use base 'Object::Accessor'; | |
629 | use strict; | |
630 | use vars qw[$AUTOLOAD]; | |
631 | ||
632 | ### constants needed to access values from the objects | |
633 | *VALUE = *Object::Accessor::VALUE; | |
634 | *ALLOW = *Object::Accessor::ALLOW; | |
635 | ||
636 | ### largely copied from O::A::Autoload | |
637 | sub AUTOLOAD : lvalue { | |
638 | my $self = shift; | |
639 | my($method) = ($AUTOLOAD =~ /([^:']+$)/); | |
640 | ||
641 | $self->___autoload( $method, @_ ) or return; | |
642 | ||
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() ]; | |
649 | } | |
650 | ||
651 | sub mk_accessors { | |
652 | my $self = shift; | |
653 | my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' ); | |
654 | ||
655 | $self->___error( | |
656 | "Allow handlers are not supported for '". __PACKAGE__ ."' objects" | |
657 | ) if $is_hash; | |
658 | ||
659 | return $self->SUPER::mk_accessors( @_ ); | |
660 | } | |
661 | ||
662 | sub register_callback { | |
663 | my $self = shift; | |
664 | $self->___error( | |
665 | "Callbacks are not supported for '". __PACKAGE__ ."' objects" | |
666 | ); | |
667 | return; | |
668 | } | |
669 | } | |
670 | ||
671 | ||
672 | ### standard tie class for bound attributes | |
673 | { package Object::Accessor::TIE; | |
674 | use Tie::Scalar; | |
675 | use Data::Dumper; | |
676 | use base 'Tie::StdScalar'; | |
677 | ||
678 | my %local = (); | |
679 | ||
680 | sub TIESCALAR { | |
681 | my $class = shift; | |
682 | my $sub = shift; | |
683 | my $ref = undef; | |
684 | my $obj = bless \$ref, $class; | |
685 | ||
686 | ### store the restore sub | |
687 | $local{ $obj } = $sub; | |
688 | return $obj; | |
689 | } | |
690 | ||
691 | sub DESTROY { | |
692 | my $tied = shift; | |
693 | my $sub = delete $local{ $tied }; | |
694 | ||
695 | ### run the restore sub to set the old value back | |
696 | return $sub->(); | |
697 | } | |
698 | } | |
699 | ||
700 | =head1 GLOBAL VARIABLES | |
701 | ||
702 | =head2 $Object::Accessor::FATAL | |
703 | ||
704 | Set this variable to true to make all attempted access to non-existant | |
705 | accessors be fatal. | |
706 | This defaults to C<false>. | |
707 | ||
708 | =head2 $Object::Accessor::DEBUG | |
709 | ||
710 | Set this variable to enable debugging output. | |
711 | This defaults to C<false>. | |
712 | ||
713 | =head1 TODO | |
714 | ||
715 | =head2 Create read-only accessors | |
716 | ||
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. | |
719 | ||
720 | =head1 CAVEATS | |
721 | ||
722 | If you use codereferences for your allow handlers, you will not be able | |
723 | to freeze the data structures using C<Storable>. | |
724 | ||
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. | |
728 | ||
729 | You can track the bug here: | |
730 | ||
731 | http://rt.cpan.org/Ticket/Display.html?id=1827 | |
732 | ||
733 | =head1 AUTHOR | |
734 | ||
735 | This module by | |
736 | Jos Boumans E<lt>kane@cpan.orgE<gt>. | |
737 | ||
738 | =head1 COPYRIGHT | |
739 | ||
740 | This module is | |
741 | copyright (c) 2004-2005 Jos Boumans E<lt>kane@cpan.orgE<gt>. | |
742 | All rights reserved. | |
743 | ||
744 | This library is free software; | |
745 | you may redistribute and/or modify it under the same | |
746 | terms as Perl itself. | |
747 | ||
748 | =cut | |
749 | ||
750 | 1; |