1 | package Attribute::Handlers;
|
---|
2 | use 5.006;
|
---|
3 | use Carp;
|
---|
4 | use warnings;
|
---|
5 | $VERSION = '0.78_02';
|
---|
6 | # $DB::single=1;
|
---|
7 |
|
---|
8 | my %symcache;
|
---|
9 | sub findsym {
|
---|
10 | my ($pkg, $ref, $type) = @_;
|
---|
11 | return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
|
---|
12 | $type ||= ref($ref);
|
---|
13 | my $found;
|
---|
14 | foreach my $sym ( values %{$pkg."::"} ) {
|
---|
15 | return $symcache{$pkg,$ref} = \$sym
|
---|
16 | if *{$sym}{$type} && *{$sym}{$type} == $ref;
|
---|
17 | }
|
---|
18 | }
|
---|
19 |
|
---|
20 | my %validtype = (
|
---|
21 | VAR => [qw[SCALAR ARRAY HASH]],
|
---|
22 | ANY => [qw[SCALAR ARRAY HASH CODE]],
|
---|
23 | "" => [qw[SCALAR ARRAY HASH CODE]],
|
---|
24 | SCALAR => [qw[SCALAR]],
|
---|
25 | ARRAY => [qw[ARRAY]],
|
---|
26 | HASH => [qw[HASH]],
|
---|
27 | CODE => [qw[CODE]],
|
---|
28 | );
|
---|
29 | my %lastattr;
|
---|
30 | my @declarations;
|
---|
31 | my %raw;
|
---|
32 | my %phase;
|
---|
33 | my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
|
---|
34 | my $global_phase = 0;
|
---|
35 | my %global_phases = (
|
---|
36 | BEGIN => 0,
|
---|
37 | CHECK => 1,
|
---|
38 | INIT => 2,
|
---|
39 | END => 3,
|
---|
40 | );
|
---|
41 | my @global_phases = qw(BEGIN CHECK INIT END);
|
---|
42 |
|
---|
43 | sub _usage_AH_ {
|
---|
44 | croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
|
---|
45 | }
|
---|
46 |
|
---|
47 | my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
|
---|
48 |
|
---|
49 | sub import {
|
---|
50 | my $class = shift @_;
|
---|
51 | return unless $class eq "Attribute::Handlers";
|
---|
52 | while (@_) {
|
---|
53 | my $cmd = shift;
|
---|
54 | if ($cmd =~ /^autotie((?:ref)?)$/) {
|
---|
55 | my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
|
---|
56 | my $mapping = shift;
|
---|
57 | _usage_AH_ $class unless ref($mapping) eq 'HASH';
|
---|
58 | while (my($attr, $tieclass) = each %$mapping) {
|
---|
59 | $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
|
---|
60 | my $args = $3||'()';
|
---|
61 | _usage_AH_ $class unless $attr =~ $qual_id
|
---|
62 | && $tieclass =~ $qual_id
|
---|
63 | && eval "use base $tieclass; 1";
|
---|
64 | if ($tieclass->isa('Exporter')) {
|
---|
65 | local $Exporter::ExportLevel = 2;
|
---|
66 | $tieclass->import(eval $args);
|
---|
67 | }
|
---|
68 | $attr =~ s/__CALLER__/caller(1)/e;
|
---|
69 | $attr = caller()."::".$attr unless $attr =~ /::/;
|
---|
70 | eval qq{
|
---|
71 | sub $attr : ATTR(VAR) {
|
---|
72 | my (\$ref, \$data) = \@_[2,4];
|
---|
73 | my \$was_arrayref = ref \$data eq 'ARRAY';
|
---|
74 | \$data = [ \$data ] unless \$was_arrayref;
|
---|
75 | my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
|
---|
76 | (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
|
---|
77 | :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
|
---|
78 | :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
|
---|
79 | : die "Can't autotie a \$type\n"
|
---|
80 | } 1
|
---|
81 | } or die "Internal error: $@";
|
---|
82 | }
|
---|
83 | }
|
---|
84 | else {
|
---|
85 | croak "Can't understand $_";
|
---|
86 | }
|
---|
87 | }
|
---|
88 | }
|
---|
89 | sub _resolve_lastattr {
|
---|
90 | return unless $lastattr{ref};
|
---|
91 | my $sym = findsym @lastattr{'pkg','ref'}
|
---|
92 | or die "Internal error: $lastattr{pkg} symbol went missing";
|
---|
93 | my $name = *{$sym}{NAME};
|
---|
94 | warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
|
---|
95 | if $^W and $name !~ /[A-Z]/;
|
---|
96 | foreach ( @{$validtype{$lastattr{type}}} ) {
|
---|
97 | *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
|
---|
98 | }
|
---|
99 | %lastattr = ();
|
---|
100 | }
|
---|
101 |
|
---|
102 | sub AUTOLOAD {
|
---|
103 | my ($class) = $AUTOLOAD =~ m/(.*)::/g;
|
---|
104 | $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
|
---|
105 | croak "Can't locate class method '$AUTOLOAD' via package '$class'";
|
---|
106 | croak "Attribute handler '$2' doesn't handle $1 attributes";
|
---|
107 | }
|
---|
108 |
|
---|
109 | sub DESTROY {}
|
---|
110 |
|
---|
111 | my $builtin = qr/lvalue|method|locked|unique|shared/;
|
---|
112 |
|
---|
113 | sub _gen_handler_AH_() {
|
---|
114 | return sub {
|
---|
115 | _resolve_lastattr;
|
---|
116 | my ($pkg, $ref, @attrs) = @_;
|
---|
117 | foreach (@attrs) {
|
---|
118 | my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
|
---|
119 | if ($attr eq 'ATTR') {
|
---|
120 | $data ||= "ANY";
|
---|
121 | $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
|
---|
122 | $phase{$ref}{BEGIN} = 1
|
---|
123 | if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
|
---|
124 | $phase{$ref}{INIT} = 1
|
---|
125 | if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
|
---|
126 | $phase{$ref}{END} = 1
|
---|
127 | if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
|
---|
128 | $phase{$ref}{CHECK} = 1
|
---|
129 | if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
|
---|
130 | || ! keys %{$phase{$ref}};
|
---|
131 | # Added for cleanup to not pollute next call.
|
---|
132 | (%lastattr = ()),
|
---|
133 | croak "Can't have two ATTR specifiers on one subroutine"
|
---|
134 | if keys %lastattr;
|
---|
135 | croak "Bad attribute type: ATTR($data)"
|
---|
136 | unless $validtype{$data};
|
---|
137 | %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
|
---|
138 | }
|
---|
139 | else {
|
---|
140 | my $type = ref $ref;
|
---|
141 | my $handler = $pkg->can("_ATTR_${type}_${attr}");
|
---|
142 | next unless $handler;
|
---|
143 | my $decl = [$pkg, $ref, $attr, $data,
|
---|
144 | $raw{$handler}, $phase{$handler}];
|
---|
145 | foreach my $gphase (@global_phases) {
|
---|
146 | _apply_handler_AH_($decl,$gphase)
|
---|
147 | if $global_phases{$gphase} <= $global_phase;
|
---|
148 | }
|
---|
149 | if ($global_phase != 0) {
|
---|
150 | # if _gen_handler_AH_ is being called after
|
---|
151 | # CHECK it's for a lexical, so make sure
|
---|
152 | # it didn't want to run anything later
|
---|
153 |
|
---|
154 | local $Carp::CarpLevel = 2;
|
---|
155 | carp "Won't be able to apply END handler"
|
---|
156 | if $phase{$handler}{END};
|
---|
157 | }
|
---|
158 | else {
|
---|
159 | push @declarations, $decl
|
---|
160 | }
|
---|
161 | }
|
---|
162 | $_ = undef;
|
---|
163 | }
|
---|
164 | return grep {defined && !/$builtin/} @attrs;
|
---|
165 | }
|
---|
166 | }
|
---|
167 |
|
---|
168 | *{"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;
|
---|
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 |
|
---|
197 | {
|
---|
198 | no warnings 'void';
|
---|
199 | CHECK {
|
---|
200 | $global_phase++;
|
---|
201 | _resolve_lastattr;
|
---|
202 | _apply_handler_AH_($_,'CHECK') foreach @declarations;
|
---|
203 | }
|
---|
204 |
|
---|
205 | INIT {
|
---|
206 | $global_phase++;
|
---|
207 | _apply_handler_AH_($_,'INIT') foreach @declarations
|
---|
208 | }
|
---|
209 | }
|
---|
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 |
|
---|
222 | This document describes version 0.78 of Attribute::Handlers,
|
---|
223 | released October 5, 2002.
|
---|
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
|
---|
602 | facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
|
---|
603 | C<__CALLER__>, which may be specified as the qualifier of an attribute:
|
---|
604 |
|
---|
605 | package Tie::Me::Kangaroo:Down::Sport;
|
---|
606 |
|
---|
607 | use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
|
---|
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 |
|
---|
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 |
|
---|
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 |
|
---|
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 |
|
---|
832 | =back
|
---|
833 |
|
---|
834 | =head1 AUTHOR
|
---|
835 |
|
---|
836 | Damian Conway ([email protected])
|
---|
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.
|
---|