File Coverage

blib/lib/Class/Declare/Attributes.pm
Criterion Covered Total %
statement 157 208 75.4
branch 11 30 36.6
condition 5 80 6.2
subroutine 48 50 96.0
pod 1 1 100.0
total 222 369 60.1


line stmt bran cond sub pod time code
1             package Class::Declare::Attributes;
2              
3 14     14   184165 use 5.006;
  14         42  
4 14     14   59 use strict;
  14         18  
  14         298  
5 14     14   54 use warnings;
  14         22  
  14         448  
6 14     14   8114 use attributes;
  14         15706  
  14         79  
7              
8 14     14   11227 use Class::Declare qw( :modifiers );
  14         257997  
  14         1875  
9 14     14   3583 use File::Spec::Functions qw();
  14         4646  
  14         310  
10 14     14   63 use base qw( Class::Declare );
  14         19  
  14         984  
11 14     14   61 use vars qw( $VERSION $REVISION );
  14         25  
  14         6151  
12              
13             $VERSION = '0.11';
14             $REVISION = '$Revision: 1515 $';
15              
16             # need to copy the export symbols from Class::Declare
17             # to permit Class::Declare::Attributes to provide attribute modifiers
18             *EXPORT_OK = *Class::Declare::EXPORT_OK;
19             *EXPORT_TAGS = *Class::Declare::EXPORT_TAGS;
20              
21              
22             # declare the 'attributes' helper routines
23             {
24             # moving "my" declarations out of BEGIN for Perl v5.8.4
25             # - this avoids "Bizarre copy of HASH in leavesub" error
26             # - this is a bug fixed in v5.8.5
27             # - see http://perlmonks.org/index.pl?node_id=361620 for more details
28             my %__ATTR__ = ();
29             my %__PKGS__ = ();
30             my %__DONE__ = ();
31              
32 0         0 BEGIN {
33              
34             # define the attributes that are wrapped by this class
35 14     14   29 %__ATTR__ = map { $_ => 1 } qw( abstract
  98         184  
36             class
37             restricted
38             static
39             public
40             protected
41             private );
42              
43             # suppress the warnings surrounding the use of attributes that may be
44             # reserved for future use
45             # - this is naughty ... oh, well ... can be changed if necessary
46             # - we want to suppress this warning without disabling all warnings
47             # - we previously set $^W to 0, but this is very heavy handed, so
48             # let's try the following
49             $SIG{__WARN__} = sub {
50             # if we detect a violation caused by C::D::A, then suppress it,
51             # otherwise let it through
52 27         6336 my $pkg = __PACKAGE__;
53             ( $_[0] =~ /attribute may clash .+? reserved word: (\w+)/o ||
54             $_[0] =~ /^Declaration of (\w+) .+? package $pkg .+? reserved word/o )
55             # ensure the attribute belongs to C::D::A
56 27 50 66     515 and ( $__ATTR__{ $1 } )
      66        
57             and return 1; # do nothing
58              
59             # otherwise, return the standard warn() response
60 13         1143 warn $_[0];
61 14         90 }; # $SIG{__WARN__}()
62              
63              
64             # keep a log of calls made to set the attributes
65 14         37 %__PKGS__ = ();
66 14         2042 %__DONE__ = ();
67              
68              
69             # MODIFY_CODE_ATTRIBUTES()
70             #
71             # Keep a reference of the and type of attribute for each method specified as
72             #
73             # sub method : type { ... }
74             #
75             sub MODIFY_CODE_ATTRIBUTES
76             {
77 30     30   1950 my ( $pkg , $ref , @attr ) = @_;
78              
79             # only consider the attributes that we know about
80 30         89 my @unknown; undef @unknown;
  30         54  
81 30         63 foreach my $attr ( @attr ) {
82             # if this not an attribute we care about, then add it to the list of
83             # attributes to return
84             push @unknown , $attr
85 30 100 50     150 and next unless ( exists $__ATTR__{ $attr } );
86              
87             # have we already assigned one of our attributes to this target?
88             # - if we have, then we should raise an error
89 14 50       64 if ( defined ( my $previous = $__PKGS__{ $pkg }->{ $ref } ) ) {
90             # if this reference has already been assigned one of our attributes,
91             # then we have a problem if we are attempting to now assign a different
92             # attribute
93             # - something declared with the same attribute twice is not a problem
94             # as we just ignore the subsequent assignment
95 0 0       0 next if ( $previous eq $attr );
96              
97             # two conflicting attribute assignments
98 0         0 die "conflicting CODE attribute assignments of '$previous' "
99             . "and '$attr' in $pkg";
100             }
101              
102             # store this attribute assignment
103 14         35 $__PKGS__{ $pkg }->{ $ref } = $attr;
104            
105             # assign the CORE 'method' attribute to this reference as well
106             # - each code reference assigned a Class::Declare::Attributes interface
107             # is also actually a method
108 14         126 attributes::->import( CORE => $ref => 'method' );
109             }
110              
111             # if we have any unknown attributes, then return them
112 30 100       455 return @unknown if ( @unknown );
113              
114             # otherwise, there's nothing more to do
115 14         43 return;
116             } # MODIFY_CODE_ATTRIBUTES()
117              
118              
119             # FETCH_CODE_ATTRIBUTES()
120             #
121             # Return the type of attribute for the given package and reference
122             sub FETCH_CODE_ATTRIBUTES
123             {
124 0     0   0 my ( $pkg , $ref ) = @_;
125              
126             # if this is known package and reference, then return its attributes
127 0         0 return $__PKGS__{ $pkg }->{ $ref };
128             } # FETCH_CODE_ATTRIBUTES()
129              
130              
131              
132             # __init__()
133             #
134             # Initialise the code wrapping for Class::Declare-style methods
135             # - this needs to be called either at INIT time or when declare() is called
136             # to ensure dynamically loaded modules are handled correctly and the
137             # strict() setting is obeyed
138             sub __init__
139             {
140 32     32   182916 my $self = __PACKAGE__->static( shift );
141 32 50       653 my @pkg = ( defined $_[0] ) ? ( $_[0] ) : keys %__PKGS__;
142              
143             # iterate through the given package(s)
144 32         171 foreach my $pkg ( @pkg ) {
145 14     14   104 no strict 'refs';
  14         28  
  14         1070  
146              
147             # do we have strict checking for this package on?
148 0         0 my $strict = $pkg->strict;
149              
150             # if we have strict checking off and we've seen this package before
151             # then we should ensure we 'unnwrap' all wrapped routines
152 0 0       0 unless ( $strict ) {
153 0 0       0 if ( my $wrapped = delete $__DONE__{ $pkg } ) {
154 0         0 while ( my ( $glob , $ref ) = each %{ $wrapped } ) {
  0         0  
155 14     14   207 no warnings 'redefine';
  14         23  
  14         1445  
156              
157 0         0 *{ $glob } = $ref;
  0         0  
158             }
159             }
160              
161             # no point proceeding, since we don't have strict checking on
162 0         0 return;
163             }
164              
165             # iterate through the symbol tree of this package
166 0         0 my $pkg_ = $pkg . '::';
167 0         0 my @names = keys %{ $pkg_ };
  0         0  
168 0         0 foreach my $name ( @names ) {
169 14     14   64 no warnings 'once';
  14         23  
  14         1690  
170              
171             # if we don't have a normal symbol table entry, then skip
172             # - occasionally we will find a reference here not a GLOB
173 0         0 my $sym = ${ $pkg_ }{ $name };
  0         0  
174 0 0       0 ( ref $sym ) and next;
175              
176             # if we don't have a CODE reference then we can't proceed
177 0 0       0 my $ref = *{ $sym }{ CODE } or next;
  0         0  
178 0         0 my @attr = grep { defined } attributes::get( $ref );
  0         0  
179              
180             # filter attributes that don't belong to the list fo C::D attributes
181 0         0 @attr = grep { defined } grep { $__ATTR__{ $_ } } @attr;
  0         0  
  0         0  
182              
183             # if there are no attributes, then there's nothing to do
184 0 0       0 ( @attr ) or next;
185              
186             # extract the name of this subroutine
187 0         0 my $glob = $pkg_ . $name;
188              
189             # if we have strict access checking, then "wrap" this routine
190 0 0       0 if ( $strict ) {
191 14     14   61 no warnings 'redefine';
  14         18  
  14         1935  
192              
193 0         0 my $type = $attr[0];
194 0     0   0 *{ $glob } = sub { $pkg->$type( $_[0] , $glob ); goto $ref };
  0         0  
  0         0  
  0         0  
195              
196             # make note that this method has been wrapped
197             # - store the original CODE reference for this glob
198 0         0 $__DONE__{ $pkg }->{ $glob } = $ref;
199             }
200             }
201             }
202             } # __init__()
203              
204             } # BEGIN()
205              
206             } # closure
207              
208              
209             # require()
210             #
211             # Load the given class using Perl's require(), ensuring __init__() is called
212             # after the class has been successfully loaded. This is to ensure the correct
213             # subroutine wrappers are put in place.
214             #
215             # If the given class contains ';' then we assume that it's the string of the
216             # class rather than the filename, so we simply eval() that, rather than trying
217             # to load it from the filesystem.
218             sub require : class
219             {
220 26     26 1 12522 my $self = shift;
221             # if there's no class then there's nothing to do
222 26 50       97 my $class = shift or return undef;
223              
224             # do we have a file or the text of the class?
225 26 50       96 if ( $class =~ m/;/o ) {
226             # we assume we have the body of a class, so we just eval() it
227 26   0 8   2170 eval $class;
  8   0 8   43  
  8   0 8   11  
  8   0 8   219  
  8   0 8   38  
  8   0 1   10  
  8   0 1   2039  
  8   0 1   39  
  8   0 1   13  
  8   0 1   220  
  8   0 1   28  
  8   0 1   9  
  8   0 1   3003  
  8   0 1   58  
  8   0 1   13  
  8   0 1   69  
  0   0 1   0  
  0   0 1   0  
  1   0 1   5  
  1   0 1   1  
  1   0 1   28  
  1   0 1   3  
  1   0 1   1  
  1   0 1   206  
  1     1   4  
  1     1   1  
  1     1   28  
  1     1   3  
  1     1   1  
  1     1   323  
  1         5  
  1         2  
  1         7  
  0         0  
  0         0  
  1         5  
  1         1  
  1         23  
  1         4  
  1         1  
  1         202  
  1         5  
  1         1  
  1         27  
  1         4  
  1         1  
  1         334  
  1         5  
  1         1  
  1         4  
  0         0  
  0         0  
  1         5  
  1         2  
  1         23  
  1         3  
  1         1  
  1         201  
  1         5  
  1         2  
  1         30  
  1         4  
  1         1  
  1         328  
  1         5  
  1         1  
  1         4  
  0         0  
  0         0  
  1         5  
  1         1  
  1         24  
  1         4  
  1         1  
  1         213  
  1         4  
  1         2  
  1         33  
  1         3  
  1         1  
  1         338  
  1         5  
  1         1  
  1         4  
  0         0  
  0         0  
  1         6  
  1         2  
  1         34  
  1         4  
  1         1  
  1         222  
  1         8  
  1         1  
  1         32  
  1         3  
  1         1  
  1         341  
  1         5  
  1         1  
  1         4  
  0            
  0            
228              
229             # otherwise we have to load the file from disk
230             } else {
231             # convert the class into a file name
232 0         0 my $file = File::Spec::Functions::catfile( split '::' , $class ) . '.pm';
233              
234             # attempt to load the file
235             # - return undef if there's a problem
236 0         0 eval { require $file };
  0         0  
237             }
238              
239             # if there were any problems, then we should fail
240 26 100       4668 ( $@ ) and return undef;
241              
242             # if we've loaded this class, then ensure __init__() is called
243 13         64 $self->__init__;
244              
245 13         27 1; # everything is OK
246 14     14   89 } # require()
  14         18  
  14         95  
247              
248              
249             # for modules loaded by use(), ensure __init__() is called prior to code
250             # execution
251 11     11   167248 INIT { __PACKAGE__->__init__ }
252              
253              
254             1; # end of module
255             __END__