1 package Attribute::Handlers;
9 my ($pkg, $ref, $type) = @_;
11 foreach my $sym ( values %{$pkg."::"} ) {
12 return $sym if *{$sym}{$type} && *{$sym}{$type} == $ref;
17 VAR => [qw[SCALAR ARRAY HASH]],
18 ANY => [qw[SCALAR ARRAY HASH CODE]],
19 "" => [qw[SCALAR ARRAY HASH CODE]],
20 SCALAR => [qw[SCALAR]],
28 my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
30 sub usage {croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}"}
36 if ($cmd eq 'autotie') {
38 usage $class unless ref($mapping) eq 'HASH';
39 while (my($attr, $tieclass) = each %$mapping) {
40 usage $class unless $attr =~ m/^[a-z]\w*(::[a-z]\w*)*$/i
41 && $tieclass =~ m/^[a-z]\w*(::[a-z]\w*)*$/i
42 && eval "use base $tieclass; 1";
44 sub $attr : ATTR(VAR) {
45 my (\$ref, \$data) = \@_[2,4];
46 \$data = [ \$data ] unless ref \$data eq 'ARRAY';
47 my \$type = ref \$ref;
48 (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',\@\$data
49 :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',\@\$data
50 :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',\@\$data
51 : die "Internal error: can't autotie \$type"
53 } or die "Internal error: $@";
57 croak "Can't understand $_";
61 sub resolve_lastattr {
62 return unless $lastattr{ref};
63 my $sym = findsym @lastattr{'pkg','ref'}
64 or die "Internal error: $lastattr{pkg} symbol went missing";
65 my $name = *{$sym}{NAME};
66 warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
67 if $^W and $name !~ /[A-Z]/;
68 foreach ( @{$validtype{$lastattr{type}}} ) {
69 *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
76 $AUTOLOAD =~ /_ATTR_(.*?)_(.*)/ or
77 croak "Can't locate class method '$AUTOLOAD' via package '$class'";
78 croak "Attribute handler '$2' doesn't handle $1 attributes";
83 my $builtin = qr/lvalue|method|locked/;
88 my ($pkg, $ref, @attrs) = @_;
90 my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/i or next;
91 if ($attr eq 'ATTR') {
93 $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
94 croak "Bad attribute type: ATTR($data)"
95 unless $validtype{$data};
96 %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
99 my $handler = $pkg->can($attr);
100 next unless $handler;
102 [$pkg, $ref, $attr, $data, $raw{$handler}];
106 return grep {defined && !/$builtin/} @attrs;
110 *{"MODIFY_${_}_ATTRIBUTES"} = handler foreach @{$validtype{ANY}};
111 push @UNIVERSAL::ISA, 'Attribute::Handlers'
112 unless grep /^Attribute::Handlers$/, @UNIVERSAL::ISA;
116 foreach (@declarations) {
117 my ($pkg, $ref, $attr, $data, $raw) = @$_;
119 my $sym = findsym($pkg, $ref);
120 $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
121 my $handler = "_ATTR_${type}_${attr}";
123 my $evaled = !$raw && eval("package $pkg; no warnings;
124 \$SIG{__WARN__}=sub{die}; [$data]");
125 $data = ($evaled && $data =~ /^\s*\[/) ? [$evaled]
126 : ($evaled) ? $evaled
128 $pkg->$handler($sym, $ref, $attr, @$data>1? $data : $data->[0]);
137 Attribute::Handlers - Simpler definition of attribute handlers
141 This document describes version 0.61 of Attribute::Handlers,
142 released May 10, 2001.
148 use Attribute::Handlers;
149 no warnings 'redefine';
152 sub Good : ATTR(SCALAR) {
153 my ($package, $symbol, $referent, $attr, $data) = @_;
155 # Invoked for any scalar variable with a :Good attribute,
156 # provided the variable was declared in MyClass (or
157 # a derived class) or typed to MyClass.
159 # Do whatever to $referent here (executed in CHECK phase).
163 sub Bad : ATTR(SCALAR) {
164 # Invoked for any scalar variable with a :Bad attribute,
165 # provided the variable was declared in MyClass (or
166 # a derived class) or typed to MyClass.
170 sub Good : ATTR(ARRAY) {
171 # Invoked for any array variable with a :Good attribute,
172 # provided the variable was declared in MyClass (or
173 # a derived class) or typed to MyClass.
177 sub Good : ATTR(HASH) {
178 # Invoked for any hash variable with a :Good attribute,
179 # provided the variable was declared in MyClass (or
180 # a derived class) or typed to MyClass.
184 sub Ugly : ATTR(CODE) {
185 # Invoked for any subroutine declared in MyClass (or a
186 # derived class) with an :Ugly attribute.
191 # Invoked for any scalar, array, hash, or subroutine
192 # with an :Omni attribute, provided the variable or
193 # subroutine was declared in MyClass (or a derived class)
194 # or the variable was typed to MyClass.
195 # Use ref($_[2]) to determine what kind of referent it was.
200 use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
202 my $next : Cycle(['A'..'Z']);
207 This module, when inherited by a package, allows that package's class to
208 define attribute handler subroutines for specific attributes. Variables
209 and subroutines subsequently defined in that package, or in packages
210 derived from that package may be given attributes with the same names as
211 the attribute handler subroutines, which will then be called at the end
212 of the compilation phase (i.e. in a C<CHECK> block).
214 To create a handler, define it as a subroutine with the same name as
215 the desired attribute, and declare the subroutine itself with the
216 attribute C<:ATTR>. For example:
219 use Attribute::Handlers;
222 my ($package, $symbol, $referent, $attr, $data) = @_;
225 *{$symbol}{NAME}, " ",
226 "($referent) ", "was just declared ",
227 "and ascribed the ${attr} attribute ",
228 "with data ($data)\n";
231 This creates an handler for the attribute C<:Loud> in the class LoudDecl.
232 Thereafter, any subroutine declared with a C<:Loud> attribute in the class
239 causes the above handler to be invoked, and passed:
245 the name of the package into which it was declared;
249 a reference to the symbol table entry (typeglob) containing the subroutine;
253 a reference to the subroutine;
257 the name of the attribute;
261 any data associated with that attribute.
265 Likewise, declaring any variables with the C<:Loud> attribute within the
274 will cause the handler to be called with a similar argument list (except,
275 of course, that C<$_[2]> will be a reference to the variable).
277 The package name argument will typically be the name of the class into
278 which the subroutine was declared, but it may also be the name of a derived
279 class (since handlers are inherited).
281 If a lexical variable is given an attribute, there is no symbol table to
282 which it belongs, so the symbol table argument (C<$_[1]>) is set to the
283 string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
284 an anonymous subroutine results in a symbol table argument of C<'ANON'>.
286 The data argument passes in the value (if any) associated with the
287 attribute. For example, if C<&foo> had been declared:
289 sub foo :Loud("turn it up to 11, man!") {...}
291 then the string C<"turn it up to 11, man!"> would be passed as the
294 Attribute::Handlers makes strenuous efforts to convert
295 the data argument (C<$_[4]>) to a useable form before passing it to
296 the handler (but see L<"Non-interpretive attribute handlers">).
297 For example, all of these:
299 sub foo :Loud(till=>ears=>are=>bleeding) {...}
300 sub foo :Loud(['till','ears','are','bleeding']) {...}
301 sub foo :Loud(qw/till ears are bleeding/) {...}
302 sub foo :Loud(qw/my, ears, are, bleeding/) {...}
303 sub foo :Loud(till,ears,are,bleeding) {...}
305 causes it to pass C<['till','ears','are','bleeding']> as the handler's
306 data argument. However, if the data can't be parsed as valid Perl, then
307 it is passed as an uninterpreted string. For example:
309 sub foo :Loud(my,ears,are,bleeding) {...}
310 sub foo :Loud(qw/my ears are bleeding) {...}
312 cause the strings C<'my,ears,are,bleeding'> and C<'qw/my ears are bleeding'>
313 respectively to be passed as the data argument.
315 If the attribute has only a single associated scalar data value, that value is
316 passed as a scalar. If multiple values are associated, they are passed as an
317 array reference. If no value is associated with the attribute, C<undef> is
321 =head2 Typed lexicals
323 Regardless of the package in which it is declared, if a lexical variable is
324 ascribed an attribute, the handler that is invoked is the one belonging to
325 the package to which it is typed. For example, the following declarations:
329 my LoudDecl $loudobj : Loud;
330 my LoudDecl @loudobjs : Loud;
331 my LoudDecl %loudobjex : Loud;
333 causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
334 defines a handler for C<:Loud> attributes).
337 =head2 Type-specific attribute handlers
339 If an attribute handler is declared and the C<:ATTR> specifier is
340 given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
341 the handler is only applied to declarations of that type. For example,
342 the following definition:
346 sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
348 creates an attribute handler that applies only to scalars:
354 my $metal : RealLoud; # invokes &LoudDecl::RealLoud
355 my @metal : RealLoud; # error: unknown attribute
356 my %metal : RealLoud; # error: unknown attribute
357 sub metal : RealLoud {...} # error: unknown attribute
359 You can, of course, declare separate handlers for these types as well
360 (but you'll need to specify C<no warnings 'redefine'> to do it quietly):
363 use Attribute::Handlers;
364 no warnings 'redefine';
366 sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
367 sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
368 sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
369 sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
371 You can also explicitly indicate that a single handler is meant to be
372 used for all types of referents like so:
375 use Attribute::Handlers;
377 sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
379 (I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
382 =head2 Non-interpretive attribute handlers
384 Occasionally the strenuous efforts Attribute::Handlers makes to convert
385 the data argument (C<$_[4]>) to a useable form before passing it to
386 the handler get in the way.
388 You can turn off that eagerness-to-help by declaring
389 an attribute handler with the the keyword C<RAWDATA>. For example:
391 sub Raw : ATTR(RAWDATA) {...}
392 sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
393 sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
395 Then the handler makes absolutely no attempt to interpret the data it
396 receives and simply passes it as a string:
398 my $power : Raw(1..100); # handlers receives "1..100"
401 =head2 Attributes as C<tie> interfaces
403 Attributes make an excellent and intuitive interface through which to tie
404 variables. For example:
406 use Attribute::Handlers;
409 sub UNIVERSAL::Cycle : ATTR(SCALAR) {
410 my ($package, $symbol, $referent, $attr, $data) = @_;
411 $data = [ $data ] unless ref $data eq 'ARRAY';
412 tie $$referent, 'Tie::Cycle', $data;
419 my $next : Cycle('A'..'Z'); # $next is now a tied variable
425 In fact, this pattern is so widely applicable that Attribute::Handlers
426 provides a way to automate it: specifying C<'autotie'> in the
427 C<use Attribute::Handlers> statement. So, the previous example,
428 could also be written:
430 use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
436 my $next : Cycle('A'..'Z'); # $next is now a tied variable
441 The argument after C<'autotie'> is a reference to a hash in which each key is
442 the name of an attribute to be created, and each value is the class to which
443 variables ascribed that attribute should be tied.
445 Note that there is no longer any need to import the Tie::Cycle module --
446 Attribute::Handlers takes care of that automagically.
448 If the attribute name is unqualified, the attribute is installed in the
449 current package. Otherwise it is installed in the qualifier's package:
454 use Attribute::Handlers autotie => {
455 Other::Good => Tie::SecureHash, # tie attr installed in Other::
456 Bad => Tie::Taxes, # tie attr installed in Here::
457 UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
463 If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
464 module, then the following code:
469 my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
471 package SomeOtherClass;
476 sub fn :Ugly(sister) :Omni('po',tent()) {...}
477 my @arr :Good :Omni(s/cie/nt/);
478 my %hsh :Good(q/bye) :Omni(q/bus/);
481 would cause the following handlers to be invoked:
483 # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
485 MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
486 'LEXICAL', # no typeglob
492 MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
493 'LEXICAL', # no typeglob
499 MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
500 'LEXICAL', # no typeglob
503 '-vorous' # eval'd attr data
507 # sub fn :Ugly(sister) :Omni('po',tent()) {...}
509 MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
510 \*SomeOtherClass::fn, # typeglob
511 \&SomeOtherClass::fn, # referent
513 'sister' # eval'd attr data
516 MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
517 \*SomeOtherClass::fn, # typeglob
518 \&SomeOtherClass::fn, # referent
520 ['po','acle'] # eval'd attr data
524 # my @arr :Good :Omni(s/cie/nt/);
526 MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
527 'LEXICAL', # no typeglob
533 MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
534 'LEXICAL', # no typeglob
537 "" # eval'd attr data
541 # my %hsh :Good(q/bye) :Omni(q/bus/);
543 MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
544 'LEXICAL', # no typeglob
547 'q/bye' # raw attr data
550 MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
551 'LEXICAL', # no typeglob
554 'bus' # eval'd attr data
558 Installing handlers into UNIVERSAL, makes them...err..universal.
561 package Descriptions;
562 use Attribute::Handlers;
565 sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
567 sub UNIVERSAL::Name :ATTR {
568 $name{$_[2]} = $_[4];
571 sub UNIVERSAL::Purpose :ATTR {
572 print STDERR "Purpose of ", &name, " is $_[4]\n";
575 sub UNIVERSAL::Unit :ATTR {
576 print STDERR &name, " measured in $_[4]\n";
583 my $capacity : Name(capacity)
584 : Purpose(to store max storage capacity for files)
590 sub foo : Purpose(to foo all data before barring it) { }
601 C<Bad attribute type: ATTR(%s)>
603 An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
604 type of referent it was defined to handle wasn't one of the five permitted:
605 C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
609 C<Attribute handler %s doesn't handle %s attributes>
611 A handler for attributes of the specified name I<was> defined, but not
612 for the specified type of declaration. Typically encountered whe trying
613 to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
614 attribute handler to some other type of variable.
618 C<Declaration of %s attribute in package %s may clash with future reserved word>
620 A handler for an attributes with an all-lowercase name was declared. An
621 attribute with an all-lowercase name might have a meaning to Perl
622 itself some day, even though most don't yet. Use a mixed-case attribute
627 C<Internal error: %s symbol went missing>
629 Something is rotten in the state of the program. An attributed
630 subroutine ceased to exist between the point it was declared and the end
631 of the compilation phase (when its attribute handler(s) would have been
638 Damian Conway (damian@conway.org)
642 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
643 Bug reports and other feedback are most welcome.
647 Copyright (c) 2001, Damian Conway. All Rights Reserved.
648 This module is free software. It may be used, redistributed
649 and/or modified under the terms of the Perl Artistic License
650 (see http://www.perl.com/perl/misc/Artistic.html)