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