lib/Attribute/Handlers.pm

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