lib/Attribute/Handlers.pm

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