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