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