lib/Attribute/Handlers.pm

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