lib/Attribute/Handlers.pm

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