File Coverage

blib/lib/Attribute/Handlers.pm
Criterion Covered Total %
statement 347 357 97.2
branch 65 102 63.7
condition 25 43 58.1
subroutine 95 96 98.9
pod 1 2 50.0
total 533 600 88.8


line stmt bran cond sub pod time code
1             package Attribute::Handlers;
2 4     4   43007 use 5.006;
  4         10  
3 4     4   14 use Carp;
  4         4  
  4         274  
4 4     4   19 use warnings;
  4         9  
  4         102  
5 4     4   15 use strict;
  4         7  
  4         111  
6 4     4   13 use vars qw($VERSION $AUTOLOAD);
  4         4  
  4         413  
7             $VERSION = '0.97_01'; # remember to update version in POD!
8             $VERSION =~ tr/_//d;
9             # $DB::single=1;
10              
11             my %symcache;
12             sub findsym {
13 74     74 1 77 my ($pkg, $ref, $type) = @_;
14 74 100       245 return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
15 73   33     238 $type ||= ref($ref);
16 4     4   14 no strict 'refs';
  4         8  
  4         282  
17 73         52 my $symtab = \%{$pkg."::"};
  73         180  
18 73         1212 for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) {
  4664         4460  
19 4664 100 100     6416 if (ref $sym && $sym == $ref) {
20 6         7 return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"};
  6         81  
21             }
22 4     4   12 use strict;
  4         7  
  4         2053  
23 4658 100       6439 next unless ref ( \$sym ) eq 'GLOB';
24             return $symcache{$pkg,$ref} = \$sym
25 4648 100 100     2896 if *{$sym}{$type} && *{$sym}{$type} == $ref;
  4648         11824  
  2340         8851  
26             }}
27             }
28              
29             my %validtype = (
30             VAR => [qw[SCALAR ARRAY HASH]],
31             ANY => [qw[SCALAR ARRAY HASH CODE]],
32             "" => [qw[SCALAR ARRAY HASH CODE]],
33             SCALAR => [qw[SCALAR]],
34             ARRAY => [qw[ARRAY]],
35             HASH => [qw[HASH]],
36             CODE => [qw[CODE]],
37             );
38             my %lastattr;
39             my @declarations;
40             my %raw;
41             my %phase;
42             my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
43             my $global_phase = 0;
44             my %global_phases = (
45             BEGIN => 0,
46             CHECK => 1,
47             INIT => 2,
48             END => 3,
49             );
50             my @global_phases = qw(BEGIN CHECK INIT END);
51              
52             sub _usage_AH_ {
53 0     0   0 croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
54             }
55              
56             my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
57              
58             sub import {
59 5     5   478 my $class = shift @_;
60 5 50       13 return unless $class eq "Attribute::Handlers";
61 5         340 while (@_) {
62 1         2 my $cmd = shift;
63 1 50       6 if ($cmd =~ /^autotie((?:ref)?)$/) {
64 1 50       3 my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
65 1         2 my $mapping = shift;
66 1 50       2 _usage_AH_ $class unless ref($mapping) eq 'HASH';
67 1         4 while (my($attr, $tieclass) = each %$mapping) {
68 3         15 $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
69 3   50     14 my $args = $3||'()';
70 3 50 33 1   204 _usage_AH_ $class unless $attr =~ $qual_id
  1   33 1   5  
  1     1   1  
  1         22  
  1         39  
  1         5  
  1         1  
  1         1  
  1         33  
  1         5  
71             && $tieclass =~ $qual_id
72             && eval "use base q\0$tieclass\0; 1";
73 3 50       22 if ($tieclass->isa('Exporter')) {
74 0         0 local $Exporter::ExportLevel = 2;
75 0         0 $tieclass->import(eval $args);
76             }
77 3         4 $attr =~ s/__CALLER__/caller(1)/e;
  0         0  
78 3 100       10 $attr = caller()."::".$attr unless $attr =~ /::/;
79 3 50 33 1 0 503 eval qq{
  1 50 33 1   3  
  1 0 33 1   1  
  1 0       33  
  1 50       4  
  1 50       1  
  1 0       22  
  1 50       3  
  1 50       1  
  1 50       22  
  1 50       3  
  1 50       1  
  1 50       31  
  1         4  
  1         1  
  1         22  
  1         3  
  1         1  
  1         22  
  1         4  
  1         1  
  1         47  
  1         7  
  1         2  
  1         35  
80             sub $attr : ATTR(VAR) {
81             my (\$ref, \$data) = \@_[2,4];
82             my \$was_arrayref = ref \$data eq 'ARRAY';
83             \$data = [ \$data ] unless \$was_arrayref;
84             my \$type = ref(\$ref)||"value (".(\$ref||"").")";
85             (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
86             :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
87             :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
88             : die "Can't autotie a \$type\n"
89             } 1
90             } or die "Internal error: $@";
91             }
92             }
93             else {
94 0         0 croak "Can't understand $_";
95             }
96             }
97             }
98              
99             # On older perls, code attribute handlers run before the sub gets placed
100             # in its package. Since the :ATTR handlers need to know the name of the
101             # sub they're applied to, the name lookup (via findsym) needs to be
102             # delayed: we do it immediately before we might need to find attribute
103             # handlers from their name. However, on newer perls (which fix some
104             # problems relating to attribute application), a sub gets placed in its
105             # package before its attributes are processed. In this case, the
106             # delayed name lookup might be too late, because the sub we're looking
107             # for might have already been replaced. So we need to detect which way
108             # round this perl does things, and time the name lookup accordingly.
109             BEGIN {
110 4     4   546 my $delayed;
111             sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
112             $delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
113             return ();
114             }
115 4     4   2192 sub Attribute::Handlers::_TEST_::t :T { }
  4         3490  
  4         16  
116 4     102   33 *_delayed_name_resolution = sub() { $delayed };
  101         237  
117 4         20 undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
118 4         352 undef &Attribute::Handlers::_TEST_::t;
119             }
120              
121             sub _resolve_lastattr {
122 21 50   22   35 return unless $lastattr{ref};
123 21 50       37 my $sym = findsym @lastattr{'pkg','ref'}
124             or die "Internal error: $lastattr{pkg} symbol went missing";
125 21         61 my $name = *{$sym}{NAME};
  21         31  
126 21 50 66     70 warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
127             if $^W and $name !~ /[A-Z]/;
128 21         18 foreach ( @{$validtype{$lastattr{type}}} ) {
  21         41  
129 4     4   19 no strict 'refs';
  4         4  
  4         1183  
130 47         31 *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
  47         1105  
131             }
132 21         50 %lastattr = ();
133             }
134              
135             sub AUTOLOAD {
136 0 0   1   0 return if $AUTOLOAD =~ /::DESTROY$/;
137 0         0 my ($class) = $AUTOLOAD =~ m/(.*)::/g;
138 0 0       0 $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
139             croak "Can't locate class method '$AUTOLOAD' via package '$class'";
140 0         0 croak "Attribute handler '$2' doesn't handle $1 attributes";
141             }
142              
143             my $builtin = qr/lvalue|method|locked|unique|shared/;
144              
145             sub _gen_handler_AH_() {
146             return sub {
147 76 50   76   12365 _resolve_lastattr if _delayed_name_resolution;
148 76         125 my ($pkg, $ref, @attrs) = @_;
149 76         218 my (undef, $filename, $linenum) = caller 2;
150 76         121 foreach (@attrs) {
151 77 50       466 my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
152 77 100       149 if ($attr eq 'ATTR') {
153 4     4   17 no strict 'refs';
  4         3  
  4         1508  
154 21   100     39 $data ||= "ANY";
155 21         58 $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
156 21 100       45 $phase{$ref}{BEGIN} = 1
157             if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
158 21 100       43 $phase{$ref}{INIT} = 1
159             if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
160 21 100       39 $phase{$ref}{END} = 1
161             if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
162             $phase{$ref}{CHECK} = 1
163             if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
164 21 100 100     50 || ! keys %{$phase{$ref}};
  20         109  
165             # Added for cleanup to not pollute next call.
166 21 50       40 (%lastattr = ()),
167             croak "Can't have two ATTR specifiers on one subroutine"
168             if keys %lastattr;
169             croak "Bad attribute type: ATTR($data)"
170 21 50       40 unless $validtype{$data};
171 21         58 %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
172 21 50       25 _resolve_lastattr unless _delayed_name_resolution;
173             }
174             else {
175 56         69 my $type = ref $ref;
176 56         311 my $handler = $pkg->can("_ATTR_${type}_${attr}");
177 56 100       122 next unless $handler;
178             my $decl = [$pkg, $ref, $attr, $data,
179 54         198 $raw{$handler}, $phase{$handler}, $filename, $linenum];
180 54         76 foreach my $gphase (@global_phases) {
181             _apply_handler_AH_($decl,$gphase)
182 216 100       440 if $global_phases{$gphase} <= $global_phase;
183             }
184 54 100       80 if ($global_phase != 0) {
185             # if _gen_handler_AH_ is being called after
186             # CHECK it's for a lexical, so make sure
187             # it didn't want to run anything later
188            
189 35         40 local $Carp::CarpLevel = 2;
190             carp "Won't be able to apply END handler"
191 35 100       390 if $phase{$handler}{END};
192             }
193             else {
194 19         27 push @declarations, $decl
195             }
196             }
197 74         103 $_ = undef;
198             }
199 75 100       121 return grep {defined && !/$builtin/} @attrs;
  76         337  
200             }
201 16     16   53 }
202              
203             {
204 4     4   18 no strict 'refs';
  4         4  
  4         562  
205             *{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
206             _gen_handler_AH_ foreach @{$validtype{ANY}};
207             }
208             push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
209             unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
210              
211             sub _apply_handler_AH_ {
212 181     181   184 my ($declaration, $phase) = @_;
213 181         282 my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
214 181 100       1038 return unless $handlerphase->{$phase};
215             # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
216 53         60 my $type = ref $ref;
217 53         89 my $handler = "_ATTR_${type}_${attr}";
218 53         80 my $sym = findsym($pkg, $ref);
219 53 50 66     341 $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
220 4     4   22 no warnings;
  4         4  
  4         431  
221 53 100 66     181 if (!$raw && defined($data)) {
222 45 50       70 if ($data ne '') {
223 45     4   2979 my $evaled = eval("package $pkg; no warnings; no strict;
  4     4   16  
  4     4   2  
  4     4   388  
  4     3   16  
  4     3   4  
  4     2   123  
  4     2   21  
  4     2   6  
  4     2   117  
  4     2   15  
  4     2   14  
  4     2   114  
  3     2   11  
  3     2   339  
  3     2   52  
  3     1   7  
  3     1   5  
  3     1   67  
  3     1   12  
  3     1   6  
  3     1   68  
  3     1   17  
  3     1   8  
  3     1   67  
  3     1   235  
  3     1   6  
  3     1   45  
  3     1   9  
  3     1   6  
  3     1   73  
  3     1   13  
  3     1   13  
  3     1   55  
  2     1   6  
  2     1   17  
  2     1   73  
  2     1   9  
  2     1   3  
  2     1   56  
  2     1   7  
  2     1   2  
  2     1   73  
  2     1   8  
  2     1   2  
  2     1   44  
  2     1   6  
  2     1   2  
  2     1   66  
  1     1   5  
  1     1   1  
  1     1   45  
  1     1   6  
  1     1   2  
  1     1   34  
  1     1   3  
  1     1   2  
  1     1   37  
  1     1   6  
  1     1   2  
  1     1   35  
  1     1   5  
  1     1   2  
  1     1   38  
  1         5  
  1         1  
  1         27  
  1         4  
  1         1  
  1         48  
  1         6  
  1         2  
  1         28  
  1         4  
  1         1  
  1         47  
  1         5  
  1         2  
  1         30  
  1         3  
  1         2  
  1         42  
  1         6  
  1         1  
  1         29  
  1         4  
  1         2  
  1         44  
  1         6  
  1         3  
  1         38  
  1         7  
  1         2  
  1         48  
  1         8  
  1         1  
  1         41  
  1         6  
  1         1  
  1         46  
  1         7  
  1         1  
  1         39  
  1         6  
  1         22  
  1         85  
  1         7  
  1         1  
  1         44  
  1         5  
  1         1  
  1         50  
  1         4  
  1         1  
  1         24  
  1         3  
  1         1  
  1         37  
  1         5  
  1         1  
  1         24  
  1         2  
  1         1  
  1         36  
  1         4  
  1         1  
  1         21  
  1         2  
  1         1  
  1         33  
  1         6  
  1         2  
  1         43  
  1         5  
  1         3  
  1         40  
  1         4  
  1         1  
  1         33  
  1         3  
  1         1  
  1         57  
  1         7  
  1         1  
  1         33  
  1         5  
  1         3  
  1         48  
  1         6  
  1         2  
  1         34  
  1         5  
  1         1  
  1         44  
  1         7  
  1         2  
  1         31  
  1         5  
  1         2  
  1         43  
  1         5  
  1         2  
  1         33  
  1         6  
  1         2  
  1         45  
  1         6  
  1         2  
  1         37  
  1         5  
  1         1  
  1         50  
  1         6  
  1         2  
  1         33  
  1         5  
  1         1  
  1         55  
224             local \$SIG{__WARN__}=sub{die}; [$data]");
225 45 100       144 $data = $evaled unless $@;
226             }
227 0         0 else { $data = undef }
228             }
229             $pkg->$handler($sym,
230 53 100 33     314 (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
231             $attr,
232             $data,
233             $phase,
234             $filename,
235             $linenum,
236             );
237 53         14863 return 1;
238             }
239              
240             {
241 4     4   19 no warnings 'void';
  4         7  
  4         573  
242             CHECK {
243 4     4   2020 $global_phase++;
244 4 50       9 _resolve_lastattr if _delayed_name_resolution;
245 4         499 foreach my $decl (@declarations) {
246 19         23 _apply_handler_AH_($decl, 'CHECK');
247             }
248             }
249              
250             INIT {
251 4     4   8 $global_phase++;
252 4         13 foreach my $decl (@declarations) {
253 19         26 _apply_handler_AH_($decl, 'INIT');
254             }
255             }
256             }
257              
258             END {
259 4     4   2690 $global_phase++;
260 4         17 foreach my $decl (@declarations) {
261 19         23 _apply_handler_AH_($decl, 'END');
262             }
263             }
264              
265             1;
266             __END__