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