| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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;
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |