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