lib/Attribute/Handlers.pm

   1 package Attribute::Handlers;
   2 use 5.006;
   3 use Carp;
   4 use warnings;
   5 $VERSION = '0.78';
   6 # $DB::single=1;
   7
   8 my %symcache;
   9 sub findsym {
  10         my ($pkg, $ref, $type) = @_;
  11         return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
  12         $type ||= ref($ref);
  13         my $found;
  14         foreach my $sym ( values %{$pkg."::"} ) {
  15             return $symcache{$pkg,$ref} = \$sym
  16                 if *{$sym}{$type} && *{$sym}{$type} == $ref;
  17         }
  18 }
  19
  20 my %validtype = (
  21         VAR     => [qw[SCALAR ARRAY HASH]],
  22         ANY     => [qw[SCALAR ARRAY HASH CODE]],
  23         ""      => [qw[SCALAR ARRAY HASH CODE]],
  24         SCALAR  => [qw[SCALAR]],
  25         ARRAY   => [qw[ARRAY]],
  26         HASH    => [qw[HASH]],
  27         CODE    => [qw[CODE]],
  28 );
  29 my %lastattr;
  30 my @declarations;
  31 my %raw;
  32 my %phase;
  33 my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
  34 my $global_phase = 0;
  35 my %global_phases = (
  36         BEGIN   => 0,
  37         CHECK   => 1,
  38         INIT    => 2,
  39         END     => 3,
  40 );
  41 my @global_phases = qw(BEGIN CHECK INIT END);
  42
  43 sub _usage_AH_ {
  44         croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
  45 }
  46
  47 my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
  48
  49 sub import {
  50     my $class = shift @_;
  51     return unless $class eq "Attribute::Handlers";
  52     while (@_) {
  53         my $cmd = shift;
  54         if ($cmd =~ /^autotie((?:ref)?)$/) {
  55             my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
  56             my $mapping = shift;
  57             _usage_AH_ $class unless ref($mapping) eq 'HASH';
  58             while (my($attr, $tieclass) = each %$mapping) {
  59                 $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
  60                 my $args = $3||'()';
  61                 _usage_AH_ $class unless $attr =~ $qual_id
  62                                  && $tieclass =~ $qual_id
  63                                  && eval "use base $tieclass; 1";
  64                 if ($tieclass->isa('Exporter')) {
  65                     local $Exporter::ExportLevel = 2;
  66                     $tieclass->import(eval $args);
  67                 }
  68                 $attr =~ s/__CALLER__/caller(1)/e;
  69                 $attr = caller()."::".$attr unless $attr =~ /::/;
  70                 eval qq{
  71                     sub $attr : ATTR(VAR) {
  72                         my (\$ref, \$data) = \@_[2,4];
  73                         my \$was_arrayref = ref \$data eq 'ARRAY';
  74                         \$data = [ \$data ] unless \$was_arrayref;
  75                         my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
  76                          (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
  77                         :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
  78                         :(\$type eq 'HASH')  ? tie \%\$ref,'$tieclass',$tiedata
  79                         : die "Can't autotie a \$type\n"
  80                     } 1
  81                 } or die "Internal error: $@";
  82             }
  83         }
  84         else {
  85             croak "Can't understand $_";
  86         }
  87     }
  88 }
  89 sub _resolve_lastattr {
  90         return unless $lastattr{ref};
  91         my $sym = findsym @lastattr{'pkg','ref'}
  92                 or die "Internal error: $lastattr{pkg} symbol went missing";
  93         my $name = *{$sym}{NAME};
  94         warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
  95                 if $^W and $name !~ /[A-Z]/;
  96         foreach ( @{$validtype{$lastattr{type}}} ) {
  97                 *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
  98         }
  99         %lastattr = ();
 100 }
 101
 102 sub AUTOLOAD {
 103         my ($class) = $AUTOLOAD =~ m/(.*)::/g;
 104         $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
 105             croak "Can't locate class method '$AUTOLOAD' via package '$class'";
 106         croak "Attribute handler '$3' doesn't handle $2 attributes";
 107 }
 108
 109 sub DESTROY {}
 110
 111 my $builtin = qr/lvalue|method|locked|unique|shared/;
 112
 113 sub _gen_handler_AH_() {
 114         return sub {
 115             _resolve_lastattr;
 116             my ($pkg, $ref, @attrs) = @_;
 117             foreach (@attrs) {
 118                 my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
 119                 if ($attr eq 'ATTR') {
 120                         $data ||= "ANY";
 121                         $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
 122                         $phase{$ref}{BEGIN} = 1
 123                                 if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
 124                         $phase{$ref}{INIT} = 1
 125                                 if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
 126                         $phase{$ref}{END} = 1
 127                                 if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
 128                         $phase{$ref}{CHECK} = 1
 129                                 if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
 130                                 || ! keys %{$phase{$ref}};
 131                         # Added for cleanup to not pollute next call.
 132                         (%lastattr = ()),
 133                         croak "Can't have two ATTR specifiers on one subroutine"
 134                                 if keys %lastattr;
 135                         croak "Bad attribute type: ATTR($data)"
 136                                 unless $validtype{$data};
 137                         %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
 138                 }
 139                 else {
 140                         my $handler = $pkg->can($attr);
 141                         next unless $handler;
 142                         my $decl = [$pkg, $ref, $attr, $data,
 143                                     $raw{$handler}, $phase{$handler}];
 144                         foreach my $gphase (@global_phases) {
 145                             _apply_handler_AH_($decl,$gphase)
 146                                 if $global_phases{$gphase} <= $global_phase;
 147                         }
 148                         if ($global_phase != 0) {
 149                                 # if _gen_handler_AH_ is being called after
 150                                 # CHECK it's for a lexical, so make sure
 151                                 # it didn't want to run anything later
 152
 153                                 local $Carp::CarpLevel = 2;
 154                                 carp "Won't be able to apply END handler"
 155                                         if $phase{$handler}{END};
 156                         }
 157                         else {
 158                                 push @declarations, $decl
 159                         }
 160                 }
 161                 $_ = undef;
 162             }
 163             return grep {defined && !/$builtin/} @attrs;
 164         }
 165 }
 166
 167 *{"MODIFY_${_}_ATTRIBUTES"} = _gen_handler_AH_ foreach @{$validtype{ANY}};
 168 push @UNIVERSAL::ISA, 'Attribute::Handlers'
 169         unless grep /^Attribute::Handlers$/, @UNIVERSAL::ISA;
 170
 171 sub _apply_handler_AH_ {
 172         my ($declaration, $phase) = @_;
 173         my ($pkg, $ref, $attr, $data, $raw, $handlerphase) = @$declaration;
 174         return unless $handlerphase->{$phase};
 175         # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
 176         my $type = ref $ref;
 177         my $handler = "_ATTR_${type}_${attr}";
 178         my $sym = findsym($pkg, $ref);
 179         $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
 180         no warnings;
 181         my $evaled = !$raw && eval("package $pkg; no warnings;
 182                                     local \$SIG{__WARN__}=sub{die}; [$data]");
 183         $data = ($evaled && $data =~ /^\s*\[/)  ? [$evaled]
 184               : ($evaled)                       ? $evaled
 185               :                                   [$data];
 186         $pkg->$handler($sym,
 187                        (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
 188                        $attr,
 189                        (@$data>1? $data : $data->[0]),
 190                        $phase,
 191                       );
 192         return 1;
 193 }
 194
 195 {
 196         no warnings 'void';
 197         CHECK {
 198                $global_phase++;
 199                _resolve_lastattr;
 200                _apply_handler_AH_($_,'CHECK') foreach @declarations;
 201         }
 202
 203         INIT {
 204                 $global_phase++;
 205                 _apply_handler_AH_($_,'INIT') foreach @declarations
 206         }
 207 }
 208
 209 END { $global_phase++; _apply_handler_AH_($_,'END') foreach @declarations }
 210
 211 1;
 212 __END__
 213
 214 =head1 NAME
 215
 216 Attribute::Handlers - Simpler definition of attribute handlers
 217
 218 =head1 VERSION
 219
 220 This document describes version 0.78 of Attribute::Handlers,
 221 released October 5, 2002.
 222
 223 =head1 SYNOPSIS
 224
 225         package MyClass;
 226         require v5.6.0;
 227         use Attribute::Handlers;
 228         no warnings 'redefine';
 229
 230
 231         sub Good : ATTR(SCALAR) {
 232                 my ($package, $symbol, $referent, $attr, $data) = @_;
 233
 234                 # Invoked for any scalar variable with a :Good attribute,
 235                 # provided the variable was declared in MyClass (or
 236                 # a derived class) or typed to MyClass.
 237
 238                 # Do whatever to $referent here (executed in CHECK phase).
 239                 ...
 240         }
 241
 242         sub Bad : ATTR(SCALAR) {
 243                 # Invoked for any scalar variable with a :Bad attribute,
 244                 # provided the variable was declared in MyClass (or
 245                 # a derived class) or typed to MyClass.
 246                 ...
 247         }
 248
 249         sub Good : ATTR(ARRAY) {
 250                 # Invoked for any array variable with a :Good attribute,
 251                 # provided the variable was declared in MyClass (or
 252                 # a derived class) or typed to MyClass.
 253                 ...
 254         }
 255
 256         sub Good : ATTR(HASH) {
 257                 # Invoked for any hash variable with a :Good attribute,
 258                 # provided the variable was declared in MyClass (or
 259                 # a derived class) or typed to MyClass.
 260                 ...
 261         }
 262
 263         sub Ugly : ATTR(CODE) {
 264                 # Invoked for any subroutine declared in MyClass (or a
 265                 # derived class) with an :Ugly attribute.
 266                 ...
 267         }
 268
 269         sub Omni : ATTR {
 270                 # Invoked for any scalar, array, hash, or subroutine
 271                 # with an :Omni attribute, provided the variable or
 272                 # subroutine was declared in MyClass (or a derived class)
 273                 # or the variable was typed to MyClass.
 274                 # Use ref($_[2]) to determine what kind of referent it was.
 275                 ...
 276         }
 277
 278
 279         use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
 280
 281         my $next : Cycle(['A'..'Z']);
 282
 283
 284 =head1 DESCRIPTION
 285
 286 This module, when inherited by a package, allows that package's class to
 287 define attribute handler subroutines for specific attributes. Variables
 288 and subroutines subsequently defined in that package, or in packages
 289 derived from that package may be given attributes with the same names as
 290 the attribute handler subroutines, which will then be called in one of
 291 the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
 292 block).
 293
 294 To create a handler, define it as a subroutine with the same name as
 295 the desired attribute, and declare the subroutine itself with the
 296 attribute C<:ATTR>. For example:
 297
 298         package LoudDecl;
 299         use Attribute::Handlers;
 300
 301         sub Loud :ATTR {
 302                 my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
 303                 print STDERR
 304                         ref($referent), " ",
 305                         *{$symbol}{NAME}, " ",
 306                         "($referent) ", "was just declared ",
 307                         "and ascribed the ${attr} attribute ",
 308                         "with data ($data)\n",
 309                         "in phase $phase\n";
 310         }
 311
 312 This creates a handler for the attribute C<:Loud> in the class LoudDecl.
 313 Thereafter, any subroutine declared with a C<:Loud> attribute in the class
 314 LoudDecl:
 315
 316         package LoudDecl;
 317
 318         sub foo: Loud {...}
 319
 320 causes the above handler to be invoked, and passed:
 321
 322 =over
 323
 324 =item [0]
 325
 326 the name of the package into which it was declared;
 327
 328 =item [1]
 329
 330 a reference to the symbol table entry (typeglob) containing the subroutine;
 331
 332 =item [2]
 333
 334 a reference to the subroutine;
 335
 336 =item [3]
 337
 338 the name of the attribute;
 339
 340 =item [4]
 341
 342 any data associated with that attribute;
 343
 344 =item [5]
 345
 346 the name of the phase in which the handler is being invoked.
 347
 348 =back
 349
 350 Likewise, declaring any variables with the C<:Loud> attribute within the
 351 package:
 352
 353         package LoudDecl;
 354
 355         my $foo :Loud;
 356         my @foo :Loud;
 357         my %foo :Loud;
 358
 359 will cause the handler to be called with a similar argument list (except,
 360 of course, that C<$_[2]> will be a reference to the variable).
 361
 362 The package name argument will typically be the name of the class into
 363 which the subroutine was declared, but it may also be the name of a derived
 364 class (since handlers are inherited).
 365
 366 If a lexical variable is given an attribute, there is no symbol table to
 367 which it belongs, so the symbol table argument (C<$_[1]>) is set to the
 368 string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
 369 an anonymous subroutine results in a symbol table argument of C<'ANON'>.
 370
 371 The data argument passes in the value (if any) associated with the
 372 attribute. For example, if C<&foo> had been declared:
 373
 374         sub foo :Loud("turn it up to 11, man!") {...}
 375
 376 then the string C<"turn it up to 11, man!"> would be passed as the
 377 last argument.
 378
 379 Attribute::Handlers makes strenuous efforts to convert
 380 the data argument (C<$_[4]>) to a useable form before passing it to
 381 the handler (but see L<"Non-interpretive attribute handlers">).
 382 For example, all of these:
 383
 384         sub foo :Loud(till=>ears=>are=>bleeding) {...}
 385         sub foo :Loud(['till','ears','are','bleeding']) {...}
 386         sub foo :Loud(qw/till ears are bleeding/) {...}
 387         sub foo :Loud(qw/my, ears, are, bleeding/) {...}
 388         sub foo :Loud(till,ears,are,bleeding) {...}
 389
 390 causes it to pass C<['till','ears','are','bleeding']> as the handler's
 391 data argument. However, if the data can't be parsed as valid Perl, then
 392 it is passed as an uninterpreted string. For example:
 393
 394         sub foo :Loud(my,ears,are,bleeding) {...}
 395         sub foo :Loud(qw/my ears are bleeding) {...}
 396
 397 cause the strings C<'my,ears,are,bleeding'> and C<'qw/my ears are bleeding'>
 398 respectively to be passed as the data argument.
 399
 400 If the attribute has only a single associated scalar data value, that value is
 401 passed as a scalar. If multiple values are associated, they are passed as an
 402 array reference. If no value is associated with the attribute, C<undef> is
 403 passed.
 404
 405
 406 =head2 Typed lexicals
 407
 408 Regardless of the package in which it is declared, if a lexical variable is
 409 ascribed an attribute, the handler that is invoked is the one belonging to
 410 the package to which it is typed. For example, the following declarations:
 411
 412         package OtherClass;
 413
 414         my LoudDecl $loudobj : Loud;
 415         my LoudDecl @loudobjs : Loud;
 416         my LoudDecl %loudobjex : Loud;
 417
 418 causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
 419 defines a handler for C<:Loud> attributes).
 420
 421
 422 =head2 Type-specific attribute handlers
 423
 424 If an attribute handler is declared and the C<:ATTR> specifier is
 425 given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
 426 the handler is only applied to declarations of that type. For example,
 427 the following definition:
 428
 429         package LoudDecl;
 430
 431         sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
 432
 433 creates an attribute handler that applies only to scalars:
 434
 435
 436         package Painful;
 437         use base LoudDecl;
 438
 439         my $metal : RealLoud;           # invokes &LoudDecl::RealLoud
 440         my @metal : RealLoud;           # error: unknown attribute
 441         my %metal : RealLoud;           # error: unknown attribute
 442         sub metal : RealLoud {...}      # error: unknown attribute
 443
 444 You can, of course, declare separate handlers for these types as well
 445 (but you'll need to specify C<no warnings 'redefine'> to do it quietly):
 446
 447         package LoudDecl;
 448         use Attribute::Handlers;
 449         no warnings 'redefine';
 450
 451         sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
 452         sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
 453         sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
 454         sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
 455
 456 You can also explicitly indicate that a single handler is meant to be
 457 used for all types of referents like so:
 458
 459         package LoudDecl;
 460         use Attribute::Handlers;
 461
 462         sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
 463
 464 (I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
 465
 466
 467 =head2 Non-interpretive attribute handlers
 468
 469 Occasionally the strenuous efforts Attribute::Handlers makes to convert
 470 the data argument (C<$_[4]>) to a useable form before passing it to
 471 the handler get in the way.
 472
 473 You can turn off that eagerness-to-help by declaring
 474 an attribute handler with the keyword C<RAWDATA>. For example:
 475
 476         sub Raw          : ATTR(RAWDATA) {...}
 477         sub Nekkid       : ATTR(SCALAR,RAWDATA) {...}
 478         sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
 479
 480 Then the handler makes absolutely no attempt to interpret the data it
 481 receives and simply passes it as a string:
 482
 483         my $power : Raw(1..100);        # handlers receives "1..100"
 484
 485 =head2 Phase-specific attribute handlers
 486
 487 By default, attribute handlers are called at the end of the compilation
 488 phase (in a C<CHECK> block). This seems to be optimal in most cases because
 489 most things that can be defined are defined by that point but nothing has
 490 been executed.
 491
 492 However, it is possible to set up attribute handlers that are called at
 493 other points in the program's compilation or execution, by explicitly
 494 stating the phase (or phases) in which you wish the attribute handler to
 495 be called. For example:
 496
 497         sub Early    :ATTR(SCALAR,BEGIN) {...}
 498         sub Normal   :ATTR(SCALAR,CHECK) {...}
 499         sub Late     :ATTR(SCALAR,INIT) {...}
 500         sub Final    :ATTR(SCALAR,END) {...}
 501         sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
 502
 503 As the last example indicates, a handler may be set up to be (re)called in
 504 two or more phases. The phase name is passed as the handler's final argument.
 505
 506 Note that attribute handlers that are scheduled for the C<BEGIN> phase
 507 are handled as soon as the attribute is detected (i.e. before any
 508 subsequently defined C<BEGIN> blocks are executed).
 509
 510
 511 =head2 Attributes as C<tie> interfaces
 512
 513 Attributes make an excellent and intuitive interface through which to tie
 514 variables. For example:
 515
 516         use Attribute::Handlers;
 517         use Tie::Cycle;
 518
 519         sub UNIVERSAL::Cycle : ATTR(SCALAR) {
 520                 my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
 521                 $data = [ $data ] unless ref $data eq 'ARRAY';
 522                 tie $$referent, 'Tie::Cycle', $data;
 523         }
 524
 525         # and thereafter...
 526
 527         package main;
 528
 529         my $next : Cycle('A'..'Z');     # $next is now a tied variable
 530
 531         while (<>) {
 532                 print $next;
 533         }
 534
 535 Note that, because the C<Cycle> attribute receives its arguments in the
 536 C<$data> variable, if the attribute is given a list of arguments, C<$data>
 537 will consist of a single array reference; otherwise, it will consist of the
 538 single argument directly. Since Tie::Cycle requires its cycling values to
 539 be passed as an array reference, this means that we need to wrap
 540 non-array-reference arguments in an array constructor:
 541
 542         $data = [ $data ] unless ref $data eq 'ARRAY';
 543
 544 Typically, however, things are the other way around: the tieable class expects
 545 its arguments as a flattened list, so the attribute looks like:
 546
 547         sub UNIVERSAL::Cycle : ATTR(SCALAR) {
 548                 my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
 549                 my @data = ref $data eq 'ARRAY' ? @$data : $data;
 550                 tie $$referent, 'Tie::Whatever', @data;
 551         }
 552
 553
 554 This software pattern is so widely applicable that Attribute::Handlers
 555 provides a way to automate it: specifying C<'autotie'> in the
 556 C<use Attribute::Handlers> statement. So, the cycling example,
 557 could also be written:
 558
 559         use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
 560
 561         # and thereafter...
 562
 563         package main;
 564
 565         my $next : Cycle(['A'..'Z']);     # $next is now a tied variable
 566
 567         while (<>) {
 568                 print $next;
 569
 570 Note that we now have to pass the cycling values as an array reference,
 571 since the C<autotie> mechanism passes C<tie> a list of arguments as a list
 572 (as in the Tie::Whatever example), I<not> as an array reference (as in
 573 the original Tie::Cycle example at the start of this section).
 574
 575 The argument after C<'autotie'> is a reference to a hash in which each key is
 576 the name of an attribute to be created, and each value is the class to which
 577 variables ascribed that attribute should be tied.
 578
 579 Note that there is no longer any need to import the Tie::Cycle module --
 580 Attribute::Handlers takes care of that automagically. You can even pass
 581 arguments to the module's C<import> subroutine, by appending them to the
 582 class name. For example:
 583
 584         use Attribute::Handlers
 585                 autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
 586
 587 If the attribute name is unqualified, the attribute is installed in the
 588 current package. Otherwise it is installed in the qualifier's package:
 589
 590         package Here;
 591
 592         use Attribute::Handlers autotie => {
 593                 Other::Good => Tie::SecureHash, # tie attr installed in Other::
 594                         Bad => Tie::Taxes,      # tie attr installed in Here::
 595             UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
 596         };
 597
 598 Autoties are most commonly used in the module to which they actually tie,
 599 and need to export their attributes to any module that calls them. To
 600 facilitiate this, Attribute::Handlers recognizes a special "pseudo-class" --
 601 C<__CALLER__>, which may be specified as the qualifier of an attribute:
 602
 603         package Tie::Me::Kangaroo:Down::Sport;
 604
 605         use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
 606
 607 This causes Attribute::Handlers to define the C<Roo> attribute in the package
 608 that imports the Tie::Me::Kangaroo:Down::Sport module.
 609
 610 Note that it is important to quote the __CALLER__::Roo identifier because
 611 a bug in perl 5.8 will refuse to parse it and cause an unknown error.
 612
 613 =head3 Passing the tied object to C<tie>
 614
 615 Occasionally it is important to pass a reference to the object being tied
 616 to the TIESCALAR, TIEHASH, etc. that ties it.
 617
 618 The C<autotie> mechanism supports this too. The following code:
 619
 620         use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
 621         my $var : Selfish(@args);
 622
 623 has the same effect as:
 624
 625         tie my $var, 'Tie::Selfish', @args;
 626
 627 But when C<"autotieref"> is used instead of C<"autotie">:
 628
 629         use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
 630         my $var : Selfish(@args);
 631
 632 the effect is to pass the C<tie> call an extra reference to the variable
 633 being tied:
 634
 635         tie my $var, 'Tie::Selfish', \$var, @args;
 636
 637
 638
 639 =head1 EXAMPLES
 640
 641 If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
 642 module, then the following code:
 643
 644         package main;
 645         use MyClass;
 646
 647         my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
 648
 649         package SomeOtherClass;
 650         use base MyClass;
 651
 652         sub tent { 'acle' }
 653
 654         sub fn :Ugly(sister) :Omni('po',tent()) {...}
 655         my @arr :Good :Omni(s/cie/nt/);
 656         my %hsh :Good(q/bye) :Omni(q/bus/);
 657
 658
 659 would cause the following handlers to be invoked:
 660
 661         # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
 662
 663         MyClass::Good:ATTR(SCALAR)( 'MyClass',          # class
 664                                     'LEXICAL',          # no typeglob
 665                                     \$slr,              # referent
 666                                     'Good',             # attr name
 667                                     undef               # no attr data
 668                                     'CHECK',            # compiler phase
 669                                   );
 670
 671         MyClass::Bad:ATTR(SCALAR)( 'MyClass',           # class
 672                                    'LEXICAL',           # no typeglob
 673                                    \$slr,               # referent
 674                                    'Bad',               # attr name
 675                                    0                    # eval'd attr data
 676                                    'CHECK',             # compiler phase
 677                                  );
 678
 679         MyClass::Omni:ATTR(SCALAR)( 'MyClass',          # class
 680                                     'LEXICAL',          # no typeglob
 681                                     \$slr,              # referent
 682                                     'Omni',             # attr name
 683                                     '-vorous'           # eval'd attr data
 684                                     'CHECK',            # compiler phase
 685                                   );
 686
 687
 688         # sub fn :Ugly(sister) :Omni('po',tent()) {...}
 689
 690         MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass',     # class
 691                                   \*SomeOtherClass::fn, # typeglob
 692                                   \&SomeOtherClass::fn, # referent
 693                                   'Ugly',               # attr name
 694                                   'sister'              # eval'd attr data
 695                                   'CHECK',              # compiler phase
 696                                 );
 697
 698         MyClass::Omni:ATTR(CODE)( 'SomeOtherClass',     # class
 699                                   \*SomeOtherClass::fn, # typeglob
 700                                   \&SomeOtherClass::fn, # referent
 701                                   'Omni',               # attr name
 702                                   ['po','acle']         # eval'd attr data
 703                                   'CHECK',              # compiler phase
 704                                 );
 705
 706
 707         # my @arr :Good :Omni(s/cie/nt/);
 708
 709         MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass',    # class
 710                                    'LEXICAL',           # no typeglob
 711                                    \@arr,               # referent
 712                                    'Good',              # attr name
 713                                    undef                # no attr data
 714                                    'CHECK',             # compiler phase
 715                                  );
 716
 717         MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass',    # class
 718                                    'LEXICAL',           # no typeglob
 719                                    \@arr,               # referent
 720                                    'Omni',              # attr name
 721                                    ""                   # eval'd attr data
 722                                    'CHECK',             # compiler phase
 723                                  );
 724
 725
 726         # my %hsh :Good(q/bye) :Omni(q/bus/);
 727
 728         MyClass::Good:ATTR(HASH)( 'SomeOtherClass',     # class
 729                                   'LEXICAL',            # no typeglob
 730                                   \%hsh,                # referent
 731                                   'Good',               # attr name
 732                                   'q/bye'               # raw attr data
 733                                   'CHECK',              # compiler phase
 734                                 );
 735
 736         MyClass::Omni:ATTR(HASH)( 'SomeOtherClass',     # class
 737                                   'LEXICAL',            # no typeglob
 738                                   \%hsh,                # referent
 739                                   'Omni',               # attr name
 740                                   'bus'                 # eval'd attr data
 741                                   'CHECK',              # compiler phase
 742                                 );
 743
 744
 745 Installing handlers into UNIVERSAL, makes them...err..universal.
 746 For example:
 747
 748         package Descriptions;
 749         use Attribute::Handlers;
 750
 751         my %name;
 752         sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
 753
 754         sub UNIVERSAL::Name :ATTR {
 755                 $name{$_[2]} = $_[4];
 756         }
 757
 758         sub UNIVERSAL::Purpose :ATTR {
 759                 print STDERR "Purpose of ", &name, " is $_[4]\n";
 760         }
 761
 762         sub UNIVERSAL::Unit :ATTR {
 763                 print STDERR &name, " measured in $_[4]\n";
 764         }
 765
 766 Let's you write:
 767
 768         use Descriptions;
 769
 770         my $capacity : Name(capacity)
 771                      : Purpose(to store max storage capacity for files)
 772                      : Unit(Gb);
 773
 774
 775         package Other;
 776
 777         sub foo : Purpose(to foo all data before barring it) { }
 778
 779         # etc.
 780
 781
 782 =head1 DIAGNOSTICS
 783
 784 =over
 785
 786 =item C<Bad attribute type: ATTR(%s)>
 787
 788 An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
 789 type of referent it was defined to handle wasn't one of the five permitted:
 790 C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
 791
 792 =item C<Attribute handler %s doesn't handle %s attributes>
 793
 794 A handler for attributes of the specified name I<was> defined, but not
 795 for the specified type of declaration. Typically encountered whe trying
 796 to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
 797 attribute handler to some other type of variable.
 798
 799 =item C<Declaration of %s attribute in package %s may clash with future reserved word>
 800
 801 A handler for an attributes with an all-lowercase name was declared. An
 802 attribute with an all-lowercase name might have a meaning to Perl
 803 itself some day, even though most don't yet. Use a mixed-case attribute
 804 name, instead.
 805
 806 =item C<Can't have two ATTR specifiers on one subroutine>
 807
 808 You just can't, okay?
 809 Instead, put all the specifications together with commas between them
 810 in a single C<ATTR(I<specification>)>.
 811
 812 =item C<Can't autotie a %s>
 813
 814 You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
 815 C<"HASH">. They're the only things (apart from typeglobs -- which are
 816 not declarable) that Perl can tie.
 817
 818 =item C<Internal error: %s symbol went missing>
 819
 820 Something is rotten in the state of the program. An attributed
 821 subroutine ceased to exist between the point it was declared and the point
 822 at which its attribute handler(s) would have been called.
 823
 824 =item C<Won't be able to apply END handler>
 825
 826 You have defined an END handler for an attribute that is being applied
 827 to a lexical variable.  Since the variable may not be available during END
 828 this won't happen.
 829
 830 =back
 831
 832 =head1 AUTHOR
 833
 834 Damian Conway (damian@conway.org)
 835
 836 =head1 BUGS
 837
 838 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
 839 Bug reports and other feedback are most welcome.
 840
 841 =head1 COPYRIGHT
 842
 843          Copyright (c) 2001, Damian Conway. All Rights Reserved.
 844        This module is free software. It may be used, redistributed
 845            and/or modified under the same terms as Perl itself.