[Summary view] [Print] [Text view]

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