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