Commit | Line | Data |
0bbb0bd4 |
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; |