lib/Attribute/Handlers.pm

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