lib/Attribute/Handlers.pm

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