lib/Attribute/Handlers.pm

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