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