lib/Attribute/Handlers.pm

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