lib/Attribute/Handlers.pm

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