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