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