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