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