lib/Object/Accessor.pm

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