File Coverage

blib/lib/Class/Autouse.pm
Criterion Covered Total %
statement 223 256 87.1
branch 79 130 60.8
condition 24 44 54.5
subroutine 38 41 92.7
pod 7 8 87.5
total 371 479 77.5


line stmt bran cond sub pod time code
1             package Class::Autouse;
2              
3             # See POD at end of file for documentation
4              
5             ### Memory Overhead: 396K
6              
7 7     7   196 use 5.005;
  7         107  
  7         69  
8 7     7   110 use strict;
  7         64  
  7         135  
9 7     7   117 no strict 'refs'; # We _really_ abuse refs :)
  7         65  
  7         95  
10 7     7   18847 use UNIVERSAL ();
  7         3426  
  7         122  
11              
12             # Avoid a 5.6 bug where a constant set to undef throws a "useless use of
13             # constant in void context" warning.
14 7     7   114 use vars qw{$DEBUG};
  7         66  
  7         107  
15             BEGIN {
16 7   50 7   161 $DEBUG ||= 0;
17             }
18              
19             # Handle the debugging switch via a constant to allow debugging
20             # to be optimised out at compile time if not needed.
21 7     7   108 use constant DEBUG => $DEBUG;
  7         64  
  7         124  
22             print "Class::Autouse::autoload -> Debugging Activated.\n" if DEBUG;
23              
24             # Become an exporter so we don't get complaints when we act as a pragma.
25             # I don't fully understand the reason for this, but it works and I can't
26             # recall how to replicate the problem, so leaving it in to avoid any
27             # possible reversion. Besides, so many things use Exporter it should
28             # be practically free to do this.
29 7     7   237 use base 'Exporter';
  7         65  
  7         154  
30              
31             # Load required modules
32             # Luckily, these are so common they are basically free
33 7     7   148 use Carp ();
  7         64  
  7         142  
34 7     7   156 use File::Spec ();
  7         64  
  7         153  
35 7     7   221 use List::Util ();
  7         98  
  7         371  
36              
37             # Globals
38 7     7   3032 use vars qw{ $VERSION $DEVEL $SUPERLOAD $NOSTAT }; # Load environment
  7         79  
  7         108  
39 7     7   519 use vars qw{ %SPECIAL %LOADED %BAD }; # Special cases
  7         77  
  7         241  
40 7     7   183 use vars qw{ $HOOKS %chased $orig_can $orig_isa }; # Working information
  7         65  
  7         85  
41              
42             # Compile-time Initialisation and Optimisation
43             BEGIN {
44 7     7   97 $VERSION = '1.27';
45              
46             # We play with UNIVERSAL::can at times, so save a backup copy
47 7         73 $orig_can = \&UNIVERSAL::can;
48 7         72 $orig_isa = \&UNIVERSAL::isa;
49              
50             # We always start with the superloader off
51 7         65 $SUPERLOAD = 0;
52              
53             # Disable stating for situations where modules are on remote disks
54 7         64 $NOSTAT = 0;
55              
56             # AUTOLOAD hook counter
57 7         62 $HOOKS = 0;
58              
59             # ERRATA
60             # Special classes are internal and should be left alone.
61             # Loaded modules are those already loaded by us.
62             # Bad classes are those that are incompatible with us.
63 7         97 %SPECIAL = map { $_ => 1 } qw{ CORE main ARRAY HASH SCALAR REF UNIVERSAL };
  49         3578  
64 7         87 %LOADED  = map { $_ => 1 } qw{ UNIVERSAL Exporter Carp File::Spec };
  28         303  
65 7         358 %BAD     = map { $_ => 1 } qw{ IO::File };
  7         86  
66              
67             # "Have we tried to autoload a method before?"
68             # Anti-loop protection. Contains fully referenced sub names
69 7         239 %chased = ();
70             }
71              
72              
73              
74              
75              
76             #####################################################################
77             # Configuration and Setting up
78              
79             # Developer mode flag.
80             # Cannot be turned off once turned on.
81             sub devel {
82 2     2 1 109 _debug(\@_, 1) if DEBUG;
83              
84             # Enable if not already
85 2 50       49 return 1 if $DEVEL;
86 2         21 $DEVEL = 1;
87              
88             # Load any unloaded modules.
89             # Most of the time there should be nothing here.
90 2         114 foreach my $class ( grep { $INC{$_} eq 'Class::Autouse' } keys %INC ) {
  132         1681  
91 1         13 $class =~ s/\//::/;
92 1         13 $class =~ s/\.pm$//i;
93 1         14 Class::Autouse->load($class);
94             }
95             }
96              
97             # Happy Fun Super Loader!
98             # The process here is to replace the &UNIVERSAL::AUTOLOAD sub
99             # ( which is just a dummy by default ) with a flexible class loader.
100             sub superloader {
101 0     0 1 0 _debug(\@_, 1) if DEBUG;
102              
103 0 0       0 unless ( $SUPERLOAD ) {
104             # Overwrite UNIVERSAL::AUTOLOAD and catch any
105             # UNIVERSAL::DESTROY calls so they don't trigger
106             # UNIVERSAL::AUTOLOAD. Anyone handling DESTROY calls
107             # via an AUTOLOAD should be summarily shot.
108 0         0 *UNIVERSAL::AUTOLOAD = \&_AUTOLOAD;
109 0         0 *UNIVERSAL::DESTROY  = \&_DESTROY;
110              
111             # Because this will never go away, we increment $HOOKS such
112             # that it will never be decremented, and thus the
113             # UNIVERSAL::can/isa hijack will never be removed.
114 0 0       0 _UPDATE_HOOKS() unless $HOOKS++;
115             }
116              
117 0         0 $SUPERLOAD = 1;
118             }
119              
120             # The main autouse sub
121             sub autouse {
122             # Operate as a function or a method
123 15 50   15 1 239 shift if $_[0] eq 'Class::Autouse';
124              
125             # Ignore calls with no arguments
126 15 100       164 return 1 unless @_;
127              
128 13         111 _debug(\@_) if DEBUG;
129              
130 13         122 foreach my $class ( grep { $_ } @_ ) {
  17         185  
131             # Control flag handling
132 17 100       249 if ( substr($class, 0, 1) eq ':' ) {
133 1 50       12 if ( $class eq ':superloader' ) {
    50          
    0          
134             # Turn on the superloader
135 0         0 Class::Autouse->superloader;
136             } elsif ( $class eq ':devel' ) {
137             # Turn on devel mode
138 1         12 Class::Autouse->devel(1);
139             } elsif ( $class eq ':nostat' ) {
140             # Disable stat checks
141 0         0 $NOSTAT = 1;
142             }
143 1         29 next;
144             }
145              
146             # Load now if in devel mode, or if its a bad class
147 16 50 33     2953 if ( $DEVEL || $BAD{$class} ) {
148 0         0 Class::Autouse->load( $class );
149 0         0 next;
150             }
151              
152             # Does the file for the class exist?
153 16         282 my $file = _class_file($class);
154 16 50       190 next if exists $INC{$file};
155 16 50 33     198 unless ( $NOSTAT or _file_exists($file) ) {
156 0         0 my $inc = join ', ', @INC;
157 0         0 _cry("Can't locate $file in \@INC (\@INC contains: $inc)");
158             }
159              
160             # Don't actually do anything if the superloader is on.
161             # It will catch all AUTOLOAD calls.
162 16 50       199 next if $SUPERLOAD;
163              
164             # Add the AUTOLOAD hook and %INC lock to prevent 'use'ing
165 16         276 *{"${class}::AUTOLOAD"} = \&_AUTOLOAD;
  16         364  
166 16         175 $INC{$file} = 'Class::Autouse';
167              
168             # When we add the first hook, hijack UNIVERSAL::can/isa
169 16 100       205 _UPDATE_HOOKS() unless $HOOKS++;
170             }
171              
172 13         244 1;
173             }
174              
175             # Import behaves the same as autouse
176 7     7   94 sub import { shift->autouse(@_) }
177              
178              
179              
180              
181              
182             #####################################################################
183             # Explicit Actions
184              
185             # Completely load a class ( The class and all its dependencies ).
186             sub load {
187 15     15 1 127 _debug(\@_, 1) if DEBUG;
188              
189 15 50       193 my $class = $_[1] or _cry('No class name specified to load');
190 15 50       165 return 1 if $LOADED{$class};
191              
192             # Load the entire ISA tree
193 15         145 my @stack = ( $class );
194 15         160 my %seen = ( UNIVERSAL => 1 );
195 15         173 my @search = ();
196 15         213 while ( my $c = shift @stack ) {
197 22 50       294 next if $seen{$c}++;
198              
199             # Ensure class is loaded
200 22 100       1303 _load($c) unless $LOADED{$c};
201              
202             # Add the class to the search list,
203             # and add the @ISA to the load stack.
204 21         245 push @search, $c;
205 21         187          unshift @stack, @{"${c}::ISA"};
  21         2228  
206             }
207              
208             # If called an an array context, return the ISA tree.
209             # In scalar context, just return true.
210 14 100       287 wantarray ? @search : 1;
211             }
212              
213             # Is a particular class installed in out @INC somewhere
214             # OR is it loaded in our program already
215             sub class_exists {
216 2     2 1 17 _debug(\@_, 1) if DEBUG;
217 2 100       24 _namespace_occupied($_[1]) or _file_exists($_[1]);
218             }
219              
220             # A more general method to answer the question
221             # "Can I call a method on this class and expect it to work"
222             # Returns undef if the class does not exist
223             # Returns 0 if the class is not loaded ( or autouse'd )
224             # Returns 1 if the class can be used.
225             sub can_call_methods {
226 0     0 0 0 _debug(\@_, 1) if DEBUG;
227 0 0       0 _namespace_occupied($_[1]) or exists $INC{_class_file($_[1])};
228             }
229              
230             # Recursive methods currently only work withing the scope of the single @INC
231             # entry containing the "top" module, and will probably stay this way
232              
233             # Autouse not only a class, but all others below it.
234             sub autouse_recursive {
235 2     2 1 19 _debug(\@_, 1) if DEBUG;
236              
237             # Just load if in devel mode
238 2 100       27 return Class::Autouse->load_recursive($_[1]) if $DEVEL;
239              
240             # Don't need to do anything if the super loader is on
241 1 50       11 return 1 if $SUPERLOAD;
242              
243             # Find all the child classes, and hand them to the autouse method
244 1         12 Class::Autouse->autouse( $_[1], _child_classes($_[1]) );
245             }
246              
247             # Load not only a class and all others below it
248             sub load_recursive {
249 1     1 1 9 _debug(\@_, 1) if DEBUG;
250              
251             # Load the parent class, and its children
252 1         12 foreach ( $_[1], _child_classes($_[1]) ) {
253 2         56 Class::Autouse->load($_);
254             }
255              
256 1         14 1;
257             }
258              
259              
260              
261              
262              
263             #####################################################################
264             # Symbol Table Hooks
265              
266             # These get hooked to various places on the symbol table,
267             # to enable the autoload functionality
268              
269             # Get's linked via the symbol table to any AUTOLOADs are required
270             sub _AUTOLOAD {
271 8     8   72 _debug(\@_, 0, ", AUTOLOAD = '$Class::Autouse::AUTOLOAD'") if DEBUG;
272              
273             # Loop detection ( Just in case )
274 8 50       91 my $method = $Class::Autouse::AUTOLOAD or _cry('Missing method name');
275 8 50       106 _cry("Undefined subroutine &$method called") if ++$chased{ $method } > 10;
276              
277             # Don't bother with special classes
278 8         131 my ($class, $function) = $method =~ m/^(.*)::(.*)$/s;
279 8 50       92 _cry("Undefined subroutine &$method called") if $SPECIAL{$class};
280              
281             # Load the class and it's dependancies, and get the search path
282 8         97 my @search = Class::Autouse->load($class);
283              
284             # Find and go to the named method
285 8     10   98 my $found = List::Util::first { defined *{"${_}::$function"}{CODE} } @search;
  10         89  
  10         125  
286 8 50       124 goto &{"${found}::$function"} if $found;
  8         122  
287              
288             # Check for package AUTOLOADs
289 0         0 foreach my $c ( @search ) {
290 0 0       0          if ( defined *{"${c}::AUTOLOAD"}{CODE} ) {
  0         0  
291             # Simulate a normal autoload call
292 0         0          ${"${c}::AUTOLOAD"} = $method;
  0         0  
293 0         0          goto &{"${c}::AUTOLOAD"};
  0         0  
294                      }
295             }
296              
297             # Can't find the method anywhere. Throw the same error Perl does.
298 0         0 _cry("Can't locate object method \"$function\" via package \"$class\"");
299             }
300              
301             # This just handles the call and does nothing
302             sub _DESTROY {
303 0     0   0 _debug(\@_) if DEBUG;
304             }
305              
306             # This is the replacement for UNIVERSAL::isa
307             sub _isa {
308 30   66 30   5027 my $class = ref $_[0] || $_[0] || return undef;
      33        
309              
310             # Shortcut for the most likely cases
311 30 100 66     328 if ( $LOADED{$class} or defined @{"${class}::ISA"} ) {
  30         409  
312 24         188 goto &{$orig_isa};
  24         543  
313             }
314              
315 6         75 _preload_class($orig_isa, @_);
316             }
317              
318             # This is the replacement for UNIVERSAL::can
319             sub _can {
320 6534   100 6534   113620 my $class = ref $_[0] || $_[0] || return undef;
      66        
321              
322             # Shortcut for the most likely cases
323 6533 100 66     84553 if ( $LOADED{$class} or defined @{"${class}::ISA"} ) {
  6533         126149  
324 6529         68136 goto &{$orig_can};
  6529         275916  
325             }
326              
327 4         43 _preload_class($orig_can, @_);
328             }
329              
330             sub _preload_class {
331 10     10   212 my $orig = shift;
332 10   33     151 my $class = ref $_[0] || $_[0] || return undef;
      33        
333              
334             # Does it look like a package?
335 10 100       206 $class =~ /^[^\W\d]\w*(?:(?:'|::)[^\W\d]\w*)*$/o or return undef;
336              
337             # Do we try to load the class
338 9         82 my $load = 0;
339 9         94 my $file = _class_file($class);
340 9 100 66     1