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