This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
60ee32a59c0726d8765033ccda59bb9f5204af9d
[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.94'; # 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.93 of Attribute::Handlers,
270 released July 20, 2011.
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,
353             $filename, $linenum) = @_;
354         print STDERR
355             ref($referent), " ",
356             *{$symbol}{NAME}, " ",
357             "($referent) ", "was just declared ",
358             "and ascribed the ${attr} attribute ",
359             "with data ($data)\n",
360             "in phase $phase\n",
361             "in file $filename at line $linenum\n";
362     }
363
364 This creates a handler for the attribute C<:Loud> in the class LoudDecl.
365 Thereafter, any subroutine declared with a C<:Loud> attribute in the class
366 LoudDecl:
367
368     package LoudDecl;
369
370     sub foo: Loud {...}
371
372 causes the above handler to be invoked, and passed:
373
374 =over
375
376 =item [0]
377
378 the name of the package into which it was declared;
379
380 =item [1]
381
382 a reference to the symbol table entry (typeglob) containing the subroutine;
383
384 =item [2]
385
386 a reference to the subroutine;
387
388 =item [3]
389
390 the name of the attribute;
391
392 =item [4]
393
394 any data associated with that attribute;
395
396 =item [5]
397
398 the name of the phase in which the handler is being invoked;
399
400 =item [6]
401
402 the filename in which the handler is being invoked;
403
404 =item [7]
405
406 the line number in this file.
407
408 =back
409
410 Likewise, declaring any variables with the C<:Loud> attribute within the
411 package:
412
413     package LoudDecl;
414
415     my $foo :Loud;
416     my @foo :Loud;
417     my %foo :Loud;
418
419 will cause the handler to be called with a similar argument list (except,
420 of course, that C<$_[2]> will be a reference to the variable).
421
422 The package name argument will typically be the name of the class into
423 which the subroutine was declared, but it may also be the name of a derived
424 class (since handlers are inherited).
425
426 If a lexical variable is given an attribute, there is no symbol table to 
427 which it belongs, so the symbol table argument (C<$_[1]>) is set to the
428 string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
429 an anonymous subroutine results in a symbol table argument of C<'ANON'>.
430
431 The data argument passes in the value (if any) associated with the
432 attribute. For example, if C<&foo> had been declared:
433
434         sub foo :Loud("turn it up to 11, man!") {...}
435
436 then a reference to an array containing the string
437 C<"turn it up to 11, man!"> would be passed as the last argument.
438
439 Attribute::Handlers makes strenuous efforts to convert
440 the data argument (C<$_[4]>) to a usable form before passing it to
441 the handler (but see L<"Non-interpretive attribute handlers">).
442 If those efforts succeed, the interpreted data is passed in an array
443 reference; if they fail, the raw data is passed as a string.
444 For example, all of these:
445
446     sub foo :Loud(till=>ears=>are=>bleeding) {...}
447     sub foo :Loud(qw/till ears are bleeding/) {...}
448     sub foo :Loud(qw/till, ears, are, bleeding/) {...}
449     sub foo :Loud(till,ears,are,bleeding) {...}
450
451 causes it to pass C<['till','ears','are','bleeding']> as the handler's
452 data argument. While:
453
454     sub foo :Loud(['till','ears','are','bleeding']) {...}
455
456 causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
457 reference specified in the data being passed inside the standard
458 array reference indicating successful interpretation.
459
460 However, if the data can't be parsed as valid Perl, then
461 it is passed as an uninterpreted string. For example:
462
463     sub foo :Loud(my,ears,are,bleeding) {...}
464     sub foo :Loud(qw/my ears are bleeding) {...}
465
466 cause the strings C<'my,ears,are,bleeding'> and
467 C<'qw/my ears are bleeding'> respectively to be passed as the
468 data argument.
469
470 If no value is associated with the attribute, C<undef> is passed.
471
472 =head2 Typed lexicals
473
474 Regardless of the package in which it is declared, if a lexical variable is
475 ascribed an attribute, the handler that is invoked is the one belonging to
476 the package to which it is typed. For example, the following declarations:
477
478     package OtherClass;
479
480     my LoudDecl $loudobj : Loud;
481     my LoudDecl @loudobjs : Loud;
482     my LoudDecl %loudobjex : Loud;
483
484 causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
485 defines a handler for C<:Loud> attributes).
486
487
488 =head2 Type-specific attribute handlers
489
490 If an attribute handler is declared and the C<:ATTR> specifier is
491 given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
492 the handler is only applied to declarations of that type. For example,
493 the following definition:
494
495     package LoudDecl;
496
497     sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
498
499 creates an attribute handler that applies only to scalars:
500
501
502     package Painful;
503     use base LoudDecl;
504
505     my $metal : RealLoud;           # invokes &LoudDecl::RealLoud
506     my @metal : RealLoud;           # error: unknown attribute
507     my %metal : RealLoud;           # error: unknown attribute
508     sub metal : RealLoud {...}      # error: unknown attribute
509
510 You can, of course, declare separate handlers for these types as well
511 (but you'll need to specify C<no warnings 'redefine'> to do it quietly):
512
513     package LoudDecl;
514     use Attribute::Handlers;
515     no warnings 'redefine';
516
517     sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
518     sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
519     sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
520     sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
521
522 You can also explicitly indicate that a single handler is meant to be
523 used for all types of referents like so:
524
525     package LoudDecl;
526     use Attribute::Handlers;
527
528     sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
529
530 (I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
531
532
533 =head2 Non-interpretive attribute handlers
534
535 Occasionally the strenuous efforts Attribute::Handlers makes to convert
536 the data argument (C<$_[4]>) to a usable form before passing it to
537 the handler get in the way.
538
539 You can turn off that eagerness-to-help by declaring
540 an attribute handler with the keyword C<RAWDATA>. For example:
541
542     sub Raw          : ATTR(RAWDATA) {...}
543     sub Nekkid       : ATTR(SCALAR,RAWDATA) {...}
544     sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
545
546 Then the handler makes absolutely no attempt to interpret the data it
547 receives and simply passes it as a string:
548
549     my $power : Raw(1..100);        # handlers receives "1..100"
550
551 =head2 Phase-specific attribute handlers
552
553 By default, attribute handlers are called at the end of the compilation
554 phase (in a C<CHECK> block). This seems to be optimal in most cases because
555 most things that can be defined are defined by that point but nothing has
556 been executed.
557
558 However, it is possible to set up attribute handlers that are called at
559 other points in the program's compilation or execution, by explicitly
560 stating the phase (or phases) in which you wish the attribute handler to
561 be called. For example:
562
563     sub Early    :ATTR(SCALAR,BEGIN) {...}
564     sub Normal   :ATTR(SCALAR,CHECK) {...}
565     sub Late     :ATTR(SCALAR,INIT) {...}
566     sub Final    :ATTR(SCALAR,END) {...}
567     sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
568
569 As the last example indicates, a handler may be set up to be (re)called in
570 two or more phases. The phase name is passed as the handler's final argument.
571
572 Note that attribute handlers that are scheduled for the C<BEGIN> phase
573 are handled as soon as the attribute is detected (i.e. before any
574 subsequently defined C<BEGIN> blocks are executed).
575
576
577 =head2 Attributes as C<tie> interfaces
578
579 Attributes make an excellent and intuitive interface through which to tie
580 variables. For example:
581
582     use Attribute::Handlers;
583     use Tie::Cycle;
584
585     sub UNIVERSAL::Cycle : ATTR(SCALAR) {
586         my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
587         $data = [ $data ] unless ref $data eq 'ARRAY';
588         tie $$referent, 'Tie::Cycle', $data;
589     }
590
591     # and thereafter...
592
593     package main;
594
595     my $next : Cycle('A'..'Z');     # $next is now a tied variable
596
597     while (<>) {
598         print $next;
599     }
600
601 Note that, because the C<Cycle> attribute receives its arguments in the
602 C<$data> variable, if the attribute is given a list of arguments, C<$data>
603 will consist of a single array reference; otherwise, it will consist of the
604 single argument directly. Since Tie::Cycle requires its cycling values to
605 be passed as an array reference, this means that we need to wrap
606 non-array-reference arguments in an array constructor:
607
608     $data = [ $data ] unless ref $data eq 'ARRAY';
609
610 Typically, however, things are the other way around: the tieable class expects
611 its arguments as a flattened list, so the attribute looks like:
612
613     sub UNIVERSAL::Cycle : ATTR(SCALAR) {
614         my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
615         my @data = ref $data eq 'ARRAY' ? @$data : $data;
616         tie $$referent, 'Tie::Whatever', @data;
617     }
618
619
620 This software pattern is so widely applicable that Attribute::Handlers
621 provides a way to automate it: specifying C<'autotie'> in the
622 C<use Attribute::Handlers> statement. So, the cycling example,
623 could also be written:
624
625     use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
626
627     # and thereafter...
628
629     package main;
630
631     my $next : Cycle(['A'..'Z']);     # $next is now a tied variable
632
633     while (<>) {
634         print $next;
635     }
636
637 Note that we now have to pass the cycling values as an array reference,
638 since the C<autotie> mechanism passes C<tie> a list of arguments as a list
639 (as in the Tie::Whatever example), I<not> as an array reference (as in
640 the original Tie::Cycle example at the start of this section).
641
642 The argument after C<'autotie'> is a reference to a hash in which each key is
643 the name of an attribute to be created, and each value is the class to which
644 variables ascribed that attribute should be tied.
645
646 Note that there is no longer any need to import the Tie::Cycle module --
647 Attribute::Handlers takes care of that automagically. You can even pass
648 arguments to the module's C<import> subroutine, by appending them to the
649 class name. For example:
650
651     use Attribute::Handlers
652          autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
653
654 If the attribute name is unqualified, the attribute is installed in the
655 current package. Otherwise it is installed in the qualifier's package:
656
657     package Here;
658
659     use Attribute::Handlers autotie => {
660          Other::Good => Tie::SecureHash, # tie attr installed in Other::
661                  Bad => Tie::Taxes,      # tie attr installed in Here::
662      UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
663     };
664
665 Autoties are most commonly used in the module to which they actually tie, 
666 and need to export their attributes to any module that calls them. To
667 facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
668 C<__CALLER__>, which may be specified as the qualifier of an attribute:
669
670     package Tie::Me::Kangaroo:Down::Sport;
671
672     use Attribute::Handlers autotie =>
673          { '__CALLER__::Roo' => __PACKAGE__ };
674
675 This causes Attribute::Handlers to define the C<Roo> attribute in the package
676 that imports the Tie::Me::Kangaroo:Down::Sport module.
677
678 Note that it is important to quote the __CALLER__::Roo identifier because
679 a bug in perl 5.8 will refuse to parse it and cause an unknown error.
680
681 =head3 Passing the tied object to C<tie>
682
683 Occasionally it is important to pass a reference to the object being tied
684 to the TIESCALAR, TIEHASH, etc. that ties it. 
685
686 The C<autotie> mechanism supports this too. The following code:
687
688     use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
689     my $var : Selfish(@args);
690
691 has the same effect as:
692
693     tie my $var, 'Tie::Selfish', @args;
694
695 But when C<"autotieref"> is used instead of C<"autotie">:
696
697     use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
698     my $var : Selfish(@args);
699
700 the effect is to pass the C<tie> call an extra reference to the variable
701 being tied:
702
703     tie my $var, 'Tie::Selfish', \$var, @args;
704
705
706
707 =head1 EXAMPLES
708
709 If the class shown in L</SYNOPSIS> were placed in the MyClass.pm
710 module, then the following code:
711
712     package main;
713     use MyClass;
714
715     my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
716
717     package SomeOtherClass;
718     use base MyClass;
719
720     sub tent { 'acle' }
721
722     sub fn :Ugly(sister) :Omni('po',tent()) {...}
723     my @arr :Good :Omni(s/cie/nt/);
724     my %hsh :Good(q/bye/) :Omni(q/bus/);
725
726
727 would cause the following handlers to be invoked:
728
729     # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
730
731     MyClass::Good:ATTR(SCALAR)( 'MyClass',          # class
732                                 'LEXICAL',          # no typeglob
733                                 \$slr,              # referent
734                                 'Good',             # attr name
735                                 undef               # no attr data
736                                 'CHECK',            # compiler phase
737                               );
738
739     MyClass::Bad:ATTR(SCALAR)( 'MyClass',           # class
740                                'LEXICAL',           # no typeglob
741                                \$slr,               # referent
742                                'Bad',               # attr name
743                                0                    # eval'd attr data
744                                'CHECK',             # compiler phase
745                              );
746
747     MyClass::Omni:ATTR(SCALAR)( 'MyClass',          # class
748                                 'LEXICAL',          # no typeglob
749                                 \$slr,              # referent
750                                 'Omni',             # attr name
751                                 '-vorous'           # eval'd attr data
752                                 'CHECK',            # compiler phase
753                               );
754
755
756     # sub fn :Ugly(sister) :Omni('po',tent()) {...}
757
758     MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass',     # class
759                               \*SomeOtherClass::fn, # typeglob
760                               \&SomeOtherClass::fn, # referent
761                               'Ugly',               # attr name
762                               'sister'              # eval'd attr data
763                               'CHECK',              # compiler phase
764                             );
765
766     MyClass::Omni:ATTR(CODE)( 'SomeOtherClass',     # class
767                               \*SomeOtherClass::fn, # typeglob
768                               \&SomeOtherClass::fn, # referent
769                               'Omni',               # attr name
770                               ['po','acle']         # eval'd attr data
771                               'CHECK',              # compiler phase
772                             );
773
774
775     # my @arr :Good :Omni(s/cie/nt/);
776
777     MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass',    # class
778                                'LEXICAL',           # no typeglob
779                                \@arr,               # referent
780                                'Good',              # attr name
781                                undef                # no attr data
782                                'CHECK',             # compiler phase
783                              );
784
785     MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass',    # class
786                                'LEXICAL',           # no typeglob
787                                \@arr,               # referent
788                                'Omni',              # attr name
789                                ""                   # eval'd attr data 
790                                'CHECK',             # compiler phase
791                              );
792
793
794     # my %hsh :Good(q/bye) :Omni(q/bus/);
795
796     MyClass::Good:ATTR(HASH)( 'SomeOtherClass',     # class
797                               'LEXICAL',            # no typeglob
798                               \%hsh,                # referent
799                               'Good',               # attr name
800                               'q/bye'               # raw attr data
801                               'CHECK',              # compiler phase
802                             );
803
804     MyClass::Omni:ATTR(HASH)( 'SomeOtherClass',     # class
805                               'LEXICAL',            # no typeglob
806                               \%hsh,                # referent
807                               'Omni',               # attr name
808                               'bus'                 # eval'd attr data
809                               'CHECK',              # compiler phase
810                             );
811
812
813 Installing handlers into UNIVERSAL, makes them...err..universal.
814 For example:
815
816     package Descriptions;
817     use Attribute::Handlers;
818
819     my %name;
820     sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
821
822     sub UNIVERSAL::Name :ATTR {
823         $name{$_[2]} = $_[4];
824     }
825
826     sub UNIVERSAL::Purpose :ATTR {
827         print STDERR "Purpose of ", &name, " is $_[4]\n";
828     }
829
830     sub UNIVERSAL::Unit :ATTR {
831         print STDERR &name, " measured in $_[4]\n";
832     }
833
834 Let's you write:
835
836     use Descriptions;
837
838     my $capacity : Name(capacity)
839                  : Purpose(to store max storage capacity for files)
840                  : Unit(Gb);
841
842
843     package Other;
844
845     sub foo : Purpose(to foo all data before barring it) { }
846
847     # etc.
848
849 =head1 UTILITY FUNCTIONS
850
851 This module offers a single utility function, C<findsym()>.
852
853 =over 4
854
855 =item findsym
856
857     my $symbol = Attribute::Handlers::findsym($package, $referent);
858
859 The function looks in the symbol table of C<$package> for the typeglob for
860 C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
861 HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
862 undef. Note that C<findsym> memoizes the typeglobs it has previously
863 successfully found, so subsequent calls with the same arguments should be
864 much faster.
865
866 =back
867
868 =head1 DIAGNOSTICS
869
870 =over
871
872 =item C<Bad attribute type: ATTR(%s)>
873
874 An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
875 type of referent it was defined to handle wasn't one of the five permitted:
876 C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
877
878 =item C<Attribute handler %s doesn't handle %s attributes>
879
880 A handler for attributes of the specified name I<was> defined, but not
881 for the specified type of declaration. Typically encountered whe trying
882 to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
883 attribute handler to some other type of variable.
884
885 =item C<Declaration of %s attribute in package %s may clash with future reserved word>
886
887 A handler for an attributes with an all-lowercase name was declared. An
888 attribute with an all-lowercase name might have a meaning to Perl
889 itself some day, even though most don't yet. Use a mixed-case attribute
890 name, instead.
891
892 =item C<Can't have two ATTR specifiers on one subroutine>
893
894 You just can't, okay?
895 Instead, put all the specifications together with commas between them
896 in a single C<ATTR(I<specification>)>.
897
898 =item C<Can't autotie a %s>
899
900 You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
901 C<"HASH">. They're the only things (apart from typeglobs -- which are
902 not declarable) that Perl can tie.
903
904 =item C<Internal error: %s symbol went missing>
905
906 Something is rotten in the state of the program. An attributed
907 subroutine ceased to exist between the point it was declared and the point
908 at which its attribute handler(s) would have been called.
909
910 =item C<Won't be able to apply END handler>
911
912 You have defined an END handler for an attribute that is being applied
913 to a lexical variable.  Since the variable may not be available during END
914 this won't happen.
915
916 =back
917
918 =head1 AUTHOR
919
920 Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
921 Garcia-Suarez (rgarciasuarez@gmail.com).
922
923 Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
924 Contact him with technical difficulties with respect to the packaging of the
925 CPAN module.
926
927 =head1 BUGS
928
929 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
930 Bug reports and other feedback are most welcome.
931
932 =head1 COPYRIGHT AND LICENSE
933
934          Copyright (c) 2001-2009, Damian Conway. All Rights Reserved.
935        This module is free software. It may be used, redistributed
936            and/or modified under the same terms as Perl itself.