lib/Attribute/Handlers.pm

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