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