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 | ||
1eea129c | 13 | $VERSION = '0.34'; |
0bbb0bd4 JB |
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 JB |
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 SP |
36 | |
37 | $bool = $obj->mk_aliases( # create an alias to an existing | |
38 | alias_name => 'method'); # method name | |
0bbb0bd4 JB |
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 SP |
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 JB |
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 JB |
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 SP |
305 | |
306 | ### is this an alias? | |
307 | if( my $org = $self->{ $acc }->[ ALIAS ] ) { | |
308 | $clone->___alias( $acc => $org ); | |
309 | } | |
0bbb0bd4 JB |
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 SP |
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 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' ) ) { | |
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 SP |
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 JB |
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 SP |
769 | =back |
770 | ||
0bbb0bd4 JB |
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 SP |
804 | =head1 BUG REPORTS |
805 | ||
806 | Please report bugs or other issues to E<lt>bug-object-accessor@rt.cpan.orgE<gt>. | |
807 | ||
0bbb0bd4 JB |
808 | =head1 AUTHOR |
809 | ||
1eea129c | 810 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
0bbb0bd4 JB |
811 | |
812 | =head1 COPYRIGHT | |
813 | ||
1eea129c SP |
814 | This library is free software; you may redistribute and/or modify it |
815 | under the same terms as Perl itself. | |
0bbb0bd4 JB |
816 | |
817 | =cut | |
818 | ||
819 | 1; |