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