File Coverage

blib/lib/Class/Autouse.pm
Criterion Covered Total %
statement 67 336 19.9
branch 3 174 1.7
condition 0 46 0.0
subroutine 18 43 41.8
pod n/a
total 88 599 14.6


line stmt bran cond sub pod time code
1             package Class::Autouse;
2              
3             # See POD at end of file for documentation
4              
5 14     14   356534 use 5.006;
  14         48  
6 14     14   72 use strict;
  14         22  
  14         400  
7 14     14   75 no strict 'refs'; # We _really_ abuse refs :)
  14         24  
  14         505  
8 14     14   8952 use UNIVERSAL ();
  14         127  
  14         325  
9              
10             # Load required modules
11             # Luckily, these are so common they are basically free
12 14     14   65 use Carp ();
  14         17  
  14         204  
13 14     14   55 use Exporter ();
  14         17  
  14         298  
14 14     14   61 use File::Spec 0.80 ();
  14         344  
  14         485  
15 14     14   65 use List::Util 1.18 ();
  14         348  
  14         287  
16 14     14   66 use Scalar::Util ();
  14         21  
  14         1110  
17              
18             # Handle optimisation switches via constants to allow debugging and
19             # similar functions to be optimised out at compile time if not in use.
20             our ($DB, $DEBUG);
21             BEGIN {
22 14 50   14   175 $DB = 0 unless defined &DB::DB;
23 14 100       441 $DEBUG = 0 unless defined $DEBUG;
24             }
25 14     14   69 use constant DB => !! $DB;
  14         30  
  14         1366  
26 14     14   67 use constant DEBUG => !! $DEBUG;
  14         18  
  14         1055  
27             print "Class::Autouse -> Debugging Activated.\n" if DEBUG;
28              
29             # Globals
30 14     14   73 use vars qw{ $VERSION @ISA };
  14         30  
  14         1043  
31 14     14   74 use vars qw{ $DEVEL $SUPERLOAD $NOSTAT $NOPREBLESS $STATICISA }; # Load environment
  14         19  
  14         1002  
32 14     14   66 use vars qw{ %SPECIAL %LOADED %BAD %TRIED_CLASS %TRIED_METHOD }; # Special cases
  14         18  
  14         1431  
33 14     14   65 use vars qw{ @LOADERS @SUGAR $HOOKS $ORIGINAL_CAN $ORIGINAL_ISA }; # Working information
  14         27  
  14         3083  
34              
35             # Compile-time Initialisation and Optimisation
36             BEGIN {
37 14     14   46 $VERSION = '1.99_04';
38              
39             # Become an exporter so we don't get complaints when we act as a pragma.
40             # I don't fully understand the reason for this, but it works and I can't
41             # recall how to replicate the problem, so leaving it in to avoid any
42             # possible reversion. Besides, so many things use Exporter it should
43             # be practically free to do this.
44 14         165 @ISA = qw{ Exporter };
45              
46             # We always start with the superloader off
47 14         22 $SUPERLOAD = 0;
48              
49             # When set, disables $obj->isa/can where $obj is blessed before its class is loaded
50             # Things will operate more quickly when set, but this breaks things if you're
51             # unserializing objects from Data::Dumper, etc., and relying on this module to
52             # load the related classes on demand.
53 14         15 $NOPREBLESS = 0;
54              
55             # Disable stating for situations where modules are on remote disks
56 14         16 $NOSTAT = 0;
57              
58             # AUTOLOAD hook counter
59 14         21 $HOOKS = 0;
60              
61             # ERRATA
62             # Special classes are internal and should be left alone.
63             # Loaded modules are those already loaded by us.
64             # Bad classes are those that are incompatible with us.
65 14         23 %BAD = map { $_ => 1 } qw{
  14         63  
66             IO::File
67             };
68              
69 14         26 %SPECIAL = map { $_ => 1 } qw{
  112         249  
70             CORE main UNIVERSAL
71             ARRAY HASH SCALAR REF GLOB
72             };
73              
74 14         38 %LOADED = map { $_ => 1 } qw{
  98         163  
75             UNIVERSAL
76             Carp
77             Exporter
78             File::Spec
79             List::Util
80             Scalar::Util
81             Class::Autouse
82             };
83              
84             # "Have we tried to autoload a class before?"
85             # Per-class loop protection and improved shortcutting.
86             # Defaults to specials+preloaded to prevent attempting them.
87 14         116 %TRIED_CLASS = ( %SPECIAL, %LOADED );
88              
89             # "Have we tried to autoload a method before?"
90             # Per-method loop protection and improved shortcutting
91 14         30 %TRIED_METHOD = ();
92              
93             # Storage for dynamic loaders (regular and sugar)
94 14         19 @LOADERS = ();
95 14         22 @SUGAR = ();
96              
97             # We play with UNIVERSAL:: functions, so save backup copies
98 14         25 $ORIGINAL_CAN = \&UNIVERSAL::can;
99 14         38207 $ORIGINAL_ISA = \&UNIVERSAL::isa;
100             }
101              
102              
103              
104              
105              
106             #####################################################################
107             # Configuration and Setting up
108              
109             # Developer mode flag.
110             # Cannot be turned off once turned on.
111             sub devel {
112 0     0     _debug(\@_, 1) if DEBUG;
113              
114             # Enable if not already
115 0 0         return 1 if $DEVEL++;
116              
117             # Load any unloaded modules.
118             # Most of the time there should be nothing here.
119 0           foreach my $class ( grep { $INC{$_} eq 'Class::Autouse' } keys %INC ) {
  0            
120 0           $class =~ s/\//::/;
121 0           $class =~ s/\.pm$//i;
122 0           Class::Autouse->load($class);
123             }
124             }
125              
126             # Happy Fun Super Loader!
127             # The process here is to replace the &UNIVERSAL::AUTOLOAD sub
128             # ( which is just a dummy by default ) with a flexible class loader.
129             sub superloader {
130 0     0     _debug(\@_, 1) if DEBUG;
131              
132             # Shortcut if needed
133 0 0         return 1 if $SUPERLOAD++;
134              
135             # Enable the global hooks
136 0           _GLOBAL_HOOKS();
137              
138 0           return 1;
139             }
140              
141             sub sugar {
142             # Operate as a function or a method
143 0 0   0     shift if $_[0] eq 'Class::Autouse';
144              
145             # Ignore calls with no arguments
146 0 0         return 1 unless @_;
147              
148 0           _debug(\@_) if DEBUG;
149              
150 0           foreach my $callback ( grep { $_ } @_ ) {
  0            
151             # Handle a callback or regex
152 0 0         unless ( ref $callback eq 'CODE' ) {
153 0           die(
154             __PACKAGE__
155             . ' takes a code reference for syntactic sugar handlers'
156             . ": unexpected value $callback has type "
157             . ref($callback)
158             );
159             }
160 0           push @SUGAR, $callback;
161              
162             # Enable global hooking
163 0           _GLOBAL_HOOKS();
164             }
165              
166 0           return 1;
167             }
168              
169             # The main autouse sub
170             sub autouse {
171             # Operate as a function or a method
172 0 0   0     shift if $_[0] eq 'Class::Autouse';
173              
174             # Ignore calls with no arguments
175 0 0         return 1 unless @_;
176              
177 0           _debug(\@_) if DEBUG;
178              
179 0           foreach my $class ( grep { $_ } @_ ) {
  0            
180 0 0         if ( ref $class ) {
181 0 0 0       unless ( ref $class eq 'Regexp' or ref $class eq 'CODE') {
182 0           die( __PACKAGE__
183             . ' can autouse explicit class names, or take a regex or subroutine reference'
184             . ": unexpected value $class has type "
185             . ref($class)
186             );
187             }
188 0           push @LOADERS, $class;
189              
190             # Enable the global hooks
191 0           _GLOBAL_HOOKS();
192              
193             # Reset shortcut cache, since we may have previously
194             # tried a class and failed, which could now work
195 0           %TRIED_CLASS = ( %SPECIAL, %LOADED );
196 0           next;
197             }
198              
199             # Control flag handling
200 0 0         if ( substr($class, 0, 1) eq ':' ) {
201 0 0         if ( $class eq ':superloader' ) {
    0          
    0          
    0          
    0          
202             # Turn on the superloader
203 0           Class::Autouse->superloader;
204             } elsif ( $class eq ':devel' ) {
205             # Turn on devel mode
206 0           Class::Autouse->devel(1);
207             } elsif ( $class eq ':nostat' ) {
208             # Disable stat checks
209 0           $NOSTAT = 1;
210             } elsif ( $class eq ':noprebless') {
211             # Disable support for objects blessed before their class module is loaded
212 0           $NOPREBLESS = 1;
213             } elsif ( $class eq ':staticisa') {
214             # Expect that @ISA won't change after loading
215             # This allows some performance tweaks
216 0           $STATICISA = 1;
217             }
218 0           next;
219             }
220              
221             # Load now if in devel mode, or if its a bad class
222 0 0 0       if ( $DEVEL || $BAD{$class} ) {
223 0           Class::Autouse->load($class);
224 0           next;
225             }
226              
227             # Does the file for the class exist?
228 0           my $file = _class_file($class);
229 0 0         next if exists $INC{$file};
230 0 0 0       unless ( $NOSTAT or _file_exists($file) ) {
231 0           my $inc = join ', ', @INC;
232 0           _cry("Can't locate $file in \@INC (\@INC contains: $inc)");
233             }
234              
235             # Don't actually do anything if the superloader is on.
236             # It will catch all AUTOLOAD calls.
237 0 0         next if $SUPERLOAD;
238              
239             # Add the AUTOLOAD hook and %INC lock to prevent 'use'ing
240 0           *{"${class}::AUTOLOAD"} = \&_AUTOLOAD;
  0            
241 0           $INC{$file} = 'Class::Autouse';
242              
243             # When we add the first hook, hijack UNIVERSAL::can/isa
244 0 0         _UPDATE_HOOKS() unless $HOOKS++;
245             }
246              
247 0           return 1;
248             }
249              
250             # Import behaves the same as autouse
251             sub import {
252 0     0     shift->autouse(@_);
253             }
254              
255              
256              
257              
258              
259             #####################################################################
260             # Explicit Actions
261              
262             # Completely load a class ( The class and all its dependencies ).
263             sub load {
264 0     0     _debug(\@_, 1) if DEBUG;
265              
266 0 0         my $class = $_[1] or _cry('No class name specified to load');
267 0 0         return 1 if $LOADED{$class};
268              
269 0           my @search = _super( $class, \&_load );
270              
271             # If called an an array context, return the ISA tree.
272             # In scalar context, just return true.
273 0 0         wantarray ? @search : 1;
274             }
275              
276             # Is a particular class installed in out @INC somewhere
277             # OR is it loaded in our program already
278             sub class_exists {
279 0     0     _debug(\@_, 1) if DEBUG;
280 0 0         _namespace_occupied($_[1]) or _file_exists($_[1]);
281             }
282              
283             # A more general method to answer the question
284             # "Can I call a method on this class and expect it to work"
285             # Returns undef if the class does not exist
286             # Returns 0 if the class is not loaded ( or autouse'd )
287             # Returns 1 if the class can be used.
288             sub can_call_methods {
289 0     0     _debug(\@_, 1) if DEBUG;
290 0 0         _namespace_occupied($_[1]) or exists $INC{_class_file($_[1])};
291             }
292              
293             # Recursive methods currently only work withing the scope of the single @INC
294             # entry containing the "top" module, and will probably stay this way
295              
296             # Autouse not only a class, but all others below it.
297             sub autouse_recursive {
298 0     0     _debug(\@_, 1) if DEBUG;
299              
300             # Just load if in devel mode
301 0 0         return Class::Autouse->load_recursive($_[1]) if $DEVEL;
302              
303             # Don't need to do anything if the super loader is on
304 0 0         return 1 if $SUPERLOAD;
305              
306             # Find all the child classes, and hand them to the autouse method
307 0           Class::Autouse->autouse( $_[1], _children($_[1]) );
308             }
309              
310             # Load not only a class and all others below it
311             sub load_recursive {
312 0     0     _debug(\@_, 1) if DEBUG;
313              
314             # Load the parent class, and its children
315 0           foreach ( $_[1], _children($_[1]) ) {
316 0           Class::Autouse->load($_);
317             }
318              
319 0           return 1;
320             }
321              
322              
323              
324              
325              
326             #####################################################################
327             # Symbol Table Hooks
328              
329             # These get hooked to various places on the symbol table,
330             # to enable the autoload functionality
331              
332             # Linked to each individual class via the symbol table
333             sub _AUTOLOAD {
334 0     0     _debug(\@_, 0, ", AUTOLOAD = '$Class::Autouse::AUTOLOAD'") if DEBUG;
335              
336             # Loop detection (just in case)
337 0 0         my $method = $Class::Autouse::AUTOLOAD or _cry('Missing method name');
338 0 0         _cry("Undefined subroutine &$method called") if ++$TRIED_METHOD{$method} > 10;
339              
340             # Don't bother with special classes
341 0           my ($class, $function) = $method =~ m/^(.*)::(.*)\z/s;
342 0 0         _cry("Undefined subroutine &$method called") if $SPECIAL{$class};
343              
344             # Load the class and it's dependancies, and get the search path
345 0           my @search = Class::Autouse->load($class);
346              
347             # Find and go to the named method
348             my $found = List::Util::first {
349 0           defined *{"${_}::$function"}{CODE}
350 0     0     } @search;
  0            
351 0 0         goto &{"${found}::$function"} if $found;
  0            
352              
353             # Check for package AUTOLOADs
354 0           foreach my $c ( @search ) {
355 0 0         if ( defined *{"${c}::AUTOLOAD"}{CODE} ) {
  0            
356             # Simulate a normal autoload call
357 0           ${"${c}::AUTOLOAD"} = $method;
  0            
358 0           goto &{"${c}::AUTOLOAD"};
  0            
359             }
360             }
361              
362             # Can't find the method anywhere. Throw the same error Perl does.
363 0           _cry("Can't locate object method \"$function\" via package \"$class\"");
364             }
365              
366             # This is a special version of the above for use in UNIVERSAL
367             # It does the :superloader, and/or also any regex or callback (code ref) loaders
368             sub _UNIVERSAL_AUTOLOAD {
369 0     0     _debug(\@_, 0, ", \$AUTOLOAD = '$Class::Autouse::AUTOLOAD'") if DEBUG;
370              
371             # Loop detection ( Just in case )
372 0 0         my $method = $Class::Autouse::AUTOLOAD or _cry('Missing method name');
373 0 0         _cry("Undefined subroutine &$method called") if ++$TRIED_METHOD{ $method } > 10;
374              
375             # Don't bother with special classes
376 0           my ($class, $function) = $method =~ m/^(.*)::(.*)\z/s;
377 0 0         _cry("Undefined subroutine &$method called") if $SPECIAL{$class};
378              
379 0           my @search;
380 0 0         if ( $SUPERLOAD ) {
381             # Only try direct loading of the class if the superloader is active.
382             # This might be installed in universal for either the superloader, special loaders, or both.
383              
384             # Load the class and it's dependancies, and get the search path
385 0           @search = Class::Autouse->load($class);
386             }
387              
388 0 0         unless ( @search ) {
389             # The special loaders will attempt to dynamically instantiate the class.
390             # They will not fire if the superloader is turned on and has already loaded the class.
391 0 0         if ( _try_loaders($class, $function, @_) ) {
392 0           my $fref = $ORIGINAL_CAN->($class, $function);
393 0 0         if ( $fref ) {
394 0           goto $fref;
395             } else {
396 0           @search = _super($class);
397             }
398             }
399             }
400              
401             # Find and go to the named method
402 0     0     my $found = List::Util::first { defined *{"${_}::$function"}{CODE} } @search;
  0            
  0            
403 0 0         goto &{"${found}::$function"} if $found;
  0            
404              
405             # Check for package AUTOLOADs
406 0           foreach my $c ( @search ) {
407 0 0         if ( defined *{"${c}::AUTOLOAD"}{CODE} ) {
  0            
408             # Simulate a normal autoload call
409 0           ${"${c}::AUTOLOAD"} = $method;
  0            
410 0           goto &{"${c}::AUTOLOAD"};
  0            
411             }
412             }
413              
414 0           for my $callback ( @SUGAR ) {
415 0           my $rv = $callback->( $class, $function, @_ );
416 0 0         goto $rv if $rv;
417             }
418              
419             # Can't find the method anywhere. Throw the same error Perl does.
420 0           _cry("Can't locate object method \"$function\" via package \"$class\"");
421             }
422              
423             # This just handles the call and does nothing.
424             # It prevents destroy calls going through to the AUTOLOAD hooks.
425             sub _UNIVERSAL_DESTROY {
426 0     0     _debug(\@_) if DEBUG;
427             }
428              
429             sub _isa {
430             # Optional performance hack
431 0 0 0 0     goto $ORIGINAL_ISA if ref $_[0] and $NOPREBLESS;
432              
433             # Load the class, unless we are sure it is already
434 0   0       my $class = ref $_[0] || $_[0] || return undef;
435 0 0 0       unless ( $TRIED_CLASS{$class} or $LOADED{$class} ) {
436 0           _preload($_[0]);
437             }
438              
439 0           goto &{$ORIGINAL_ISA};
  0            
440             }
441              
442             # This is the replacement for UNIVERSAL::can
443             sub _can {
444             # Optional performance hack
445 0 0 0 0     goto $ORIGINAL_CAN if ref $_[0] and $NOPREBLESS;
446              
447             # Load the class, unless we are sure it is already
448 0   0       my $class = ref $_[0] || $_[0] || return undef;
449 0 0 0       unless ( $TRIED_CLASS{$class} or $LOADED{$class} ) {
450 0           _preload($_[0]);
451             }
452              
453 0           goto &{$ORIGINAL_CAN};
  0            
454             }
455              
456              
457              
458              
459              
460             #####################################################################
461             # Support Functions
462              
463             sub _preload {
464 0     0     _debug(\@_) if DEBUG;
465              
466             # Does it look like a package?
467 0   0       my $class = ref $_[0] || $_[0];
468 0 0 0       unless ( $class and $class =~ /^[^\W\d]\w*(?:(?:\'|::)[^\W]\w*)*$/o ) {
469 0           return $LOADED{$class} = 1;
470             }
471              
472             # Do we try to load the class
473 0           my $load = 0;
474 0           my $file = _class_file($class);
475 0 0 0       if ( defined $INC{$file} and $INC{$file} eq 'Class::Autouse' ) {
    0          
    0          
476             # It's an autoused class
477 0           $load = 1;
478             } elsif ( ! $SUPERLOAD ) {
479             # Superloader isn't on, don't load
480 0           $load = 0;
481             } elsif ( _namespace_occupied($class) ) {
482             # Superloader is on, but there is something already in the class
483             # This can't be the autouse loader, because we would have caught
484             # that case already.
485 0           $load = 0;
486             } else {
487             # The rules of the superloader say we assume loaded unless we can
488             # tell otherwise. Thus, we have to have a go at loading.
489 0           $load = 1;
490             }
491              
492             # If needed, load the class and all its dependencies.
493 0 0         Class::Autouse->load($class) if $load;
494              
495 0 0         unless ( $LOADED{$class} ) {
496 0           _try_loaders($class);
497 0 0         unless ( $LOADED{$class} ) {
498 0 0         if ( _namespace_occupied($class) ) {
499             # The class is not flagged as loaded by autouse, but exists
500             # to ensure its ancestry is loaded before calling $orig
501 0           $LOADED{$class} = 1;
502 0           _load_ancestors($class);
503             }
504             }
505             }
506              
507 0           return 1;
508             }
509              
510             sub _try_loaders {
511 0     0     _debug(\@_, 0) if DEBUG;
512 0           my ($class, $function, @optional_args) = @_;
513             # The function and args are only present to help callbacks whose main goal is to
514             # do "syntactic sugar" instead of really writing a class
515              
516             # This allows us to shortcut out of re-checking a class
517 0           $TRIED_CLASS{$class}++;
518              
519 0 0         if ( _namespace_occupied($class) ) {
520 0           $LOADED{$class} = 1;
521 0           _load_ancestors($class);
522 0           return 1;
523             }
524              
525             # Try each of the special loaders, if there are any.
526 0           for my $loader ( @LOADERS ) {
527 0           my $ref = ref($loader);
528 0 0         if ( $ref ) {
529 0 0         if ( $ref eq "Regexp" ) {
    0          
530 0 0         next unless $class =~ $loader;
531 0           my $file = _class_file($class);
532 0 0         next unless grep { -e $_ . '/' . $file } @INC;
  0            
533 0           local $^W = 0;
534 0           local $@;
535 0           eval "use $class";
536 0 0         die "Class::Autouse found module $file for class $class matching regex '$loader',"
537             . " but it failed to compile with the following error: $@" if $@;
538             } elsif ( $ref eq "CODE" ) {
539 0 0         unless ( $loader->( $class,$function,@optional_args ) ) {
540 0           next;
541             }
542             } else {
543 0           die "Unexpected loader. Expected qr//, sub{}, or class name string."
544             }
545 0           $LOADED{$class} = 1;
546 0           _load_ancestors($class);
547 0           return 1;
548             } else {
549 0           die "Odd loader $loader passed to " . __PACKAGE__;
550             }
551             }
552              
553 0           return;
554             }
555              
556             # This is called after any class is hit by load/preload to ensure that parent classes are also loaded
557             sub _load_ancestors {
558 0     0     _debug(\@_, 0) if DEBUG;
559 0           my $class = $_[0];
560 0           my ($this_class,@ancestors) = _super($class);
561 0           for my $ancestor ( @ancestors ) {
562             # this is a bit ugly, _preload presumes either isa or can is being called,
563             # and does a goto at the end of it, we just want the core logic, not the redirection
564             # so we pass undef as the subref parameter
565 0           _preload($ancestor);
566             }
567 0 0         if ( $STATICISA ) {
568             # Optional performance optimization.
569             # After we have the entire ancestry,
570             # set the greatest grandparent's can/isa to the originals.
571             # This keeps the versions in this module from being used where they're not needed.
572 0   0       my $final_parent = $ancestors[-1] || $this_class;
573 14     14   118 no strict 'refs';
  14         19  
  14         28210  
574 0           *{ $final_parent . '::can'} = $ORIGINAL_CAN;
  0            
575 0           *{ $final_parent . '::isa'} = $ORIGINAL_ISA;
  0            
576             }
577 0           return 1;
578             }
579              
580             # This walks the @ISA tree, optionally calling a subref on each class
581             # and returns the inherited classes in a list, including $class itself.
582             sub _super {
583 0     0     _debug(\@_) if DEBUG;
584 0           my $class = shift;
585 0           my $load = shift;
586 0           my @stack = ( $class );
587 0           my %seen = ( UNIVERSAL => 1 );
588 0           my @search = ();
589              
590 0           while ( my $c = shift @stack ) {
591 0 0         next if $seen{$c}++;
592              
593             # This may load the class in question, so
594             # we call it before checking @ISA.
595 0 0 0       if ( $load and not $LOADED{$c} ) {
596 0           $load->($c);
597             }
598              
599             # Add the class to the search list,
600             # and add the @ISA to the load stack.
601 0           push @search, $c;
602 0           unshift @stack, @{"${c}::ISA"};
  0            
603             }
604              
605 0           return @search;
606             }
607              
608             # Load a single class
609             sub _load ($) {
610 0     0     _debug(\@_) if DEBUG;
611              
612             # Don't attempt to load special classes
613 0 0         my $class = shift or _cry('Did not specify a class to load');
614 0           $TRIED_CLASS{$class}++;
615              
616 0 0         return 1 if $SPECIAL{$class};
617              
618             # Run some checks
619 0           my $file = _class_file($class);
620 0 0         if ( defined $INC{$file} ) {
    0          
621             # If the %INC lock is set to any other value, the file is
622             # already loaded. We do not need to do anything.
623 0 0         if ( $INC{$file} ne 'Class::Autouse') {
624 0           return $LOADED{$class} = 1;
625             }
626              
627             # Because we autoused it earlier, we know the file for this
628             # class MUST exist.
629             # Removing the AUTOLOAD hook and %INC lock is all we have to do
630 0           delete ${"${class}::"}{'AUTOLOAD'};
  0            
631 0           delete $INC{$file};
632              
633             } elsif ( not _file_exists($file) ) {
634             # We might still be loaded, if the class was defined
635             # in some other module without it's own file.
636 0 0         if ( _namespace_occupied($class) ) {
637 0           return $LOADED{$class} = 1;
638             }
639              
640             # Not loaded and no file either.
641             # Try to generate the class instead.
642 0 0         if ( _try_loaders($class) ) {
643 0           return 1;
644             }
645              
646             # We've run out of options, it just doesn't exist
647 0           my $inc = join ', ', @INC;
648 0           _cry("Can't locate $file in \@INC (\@INC contains: $inc)");
649             }
650              
651             # Load the file for this class
652 0           print _depth(1) . " Class::Autouse::load -> Loading in $file\n" if DEBUG;
653 0           eval {
654 0           CORE::require($file);
655             };
656 0 0         _cry($@) if $@;
657              
658             # Give back UNIVERSAL::can/isa if there are no other hooks
659 0 0         --$HOOKS or _UPDATE_HOOKS();
660              
661 0           $LOADED{$class} = 1;
662 0           _load_ancestors($class);
663 0           return 1;
664             }
665              
666             # Find all the child classes for a parent class.
667             # Returns in the list context.
668             sub _children ($) {
669 0     0     _debug(\@_) if DEBUG;
670              
671             # Find where it is in @INC
672 0           my $base_file = _class_file(shift);
673             my $inc_path = List::Util::first {
674 0     0     -f File::Spec->catfile($_, $base_file)
675 0 0         } @INC or return;
676              
677             # Does the file have a subdirectory
678             # i.e. Are there child classes
679 0           my $child_path = substr( $base_file, 0, length($base_file) - 3 );
680 0           my $child_path_full = File::Spec->catdir( $inc_path, $child_path );
681 0 0 0       return 0 unless -d $child_path_full and -r _;
682              
683             # Main scan loop
684 0           local *FILELIST;
685 0           my ($dir, @files, @modules) = ();
686 0           my @queue = ( $child_path );
687 0           while ( $dir = pop @queue ) {
688 0           my $full_dir = File::Spec->catdir($inc_path, $dir);
689              
690             # Read in the raw file list
691             # Skip directories we can't open
692 0 0         opendir( FILELIST, $full_dir ) or next;
693 0           @files = readdir FILELIST;
694 0           closedir FILELIST;
695              
696             # Iterate over them
697 0           @files = map { File::Spec->catfile($dir, $_) } # Full relative path
698 0           grep { ! /^\./ } @files; # Ignore hidden files
  0            
699 0           foreach my $file ( @files ) {
700 0           my $full_file = File::Spec->catfile($inc_path, $file);
701              
702             # Add to the queue if its a directory we can descend
703 0 0 0       if ( -d $full_file and -r _ ) {
704 0           push @queue, $file;
705 0           next;
706             }
707              
708             # We only want .pm files we can read
709 0 0         next unless substr( $file, length($file) - 3 ) eq '.pm';
710 0 0         next unless -f _;
711              
712 0           push @modules, $file;
713             }
714             }
715              
716             # Convert the file names into modules
717 0           map { join '::', File::Spec->splitdir($_) }
718 0           map { substr($_, 0, length($_) - 3) } @modules;
  0            
719             }
720              
721              
722              
723              
724              
725             #####################################################################
726             # Private support methods
727              
728             # Does a class or file exists somewhere in our include path. For
729             # convenience, returns the unresolved file name ( even if passed a class )
730             sub _file_exists ($) {
731 0     0     _debug(\@_) if DEBUG;
732              
733             # What are we looking for?
734 0 0         my $file = shift or return undef;
735 0 0         return undef if $file =~ m/(?:\012|\015)/o;
736              
737             # If provided a class name, convert it
738 0 0         $file = _class_file($file) if $file =~ /::/o;
739              
740             # Scan @INC for the file
741 0           foreach ( @INC ) {
742 0 0         next if ref $_ eq 'CODE';
743 0 0         return $file if -f File::Spec->catfile($_, $file);
744             }
745              
746 0           undef;
747             }
748              
749             # Is a namespace occupied by anything significant
750             sub _namespace_occupied ($) {
751             _debug(\@_) if DEBUG;
752              
753             # Handle the most likely case
754             my $class = shift or return undef;
755             return 1 if defined @{"${class}::ISA"};
756              
757             # Get the list of glob names, ignoring namespaces
758             foreach ( keys %{"${class}::"} ) {
759             next if substr($_, -2) eq '::';
760              
761             # Only check for methods, since that's all that's reliable
762             if (defined *{"${class}::$_"}{CODE}) {
763             if ($_ eq 'AUTOLOAD' and \&{"${class}::$_"} == \&_AUTOLOAD) {
764             # This is a Class::Autouse hook. Ignore.
765             next;
766             }
767             else {
768             return 1;
769             }
770             }
771             }
772              
773             '';
774             }
775              
776             # For a given class, get the file name
777             sub _class_file ($) {
778             join( '/', split /(?:\'|::)/, shift ) . '.pm';
779             }
780              
781             # Establish our call depth
782             sub _depth {
783             my $spaces = shift;
784             if ( DEBUG and ! $spaces ) {
785             _debug(\@_);
786             }
787              
788             # Search up the caller stack to find the first call that isn't us.
789             my $level = 0;
790             while( $level++ < 1000 ) {
791             my @call = caller($level);
792             if ( @call ) {
793             next if $call[3] eq '(eval)';
794             next if $call[3] =~ /^Class::Autouse::\w+\z/;
795             }
796              
797             # Subtract 1 for this sub's call
798             $level -= 1;
799             return $spaces ? join( '', (' ') x ($level - 2)) : $level;
800             }
801              
802             Carp::croak('Infinite loop trying to find call depth');
803             }
804              
805             # Die gracefully
806             sub _cry {
807             _debug() if DEBUG;
808             local $Carp::CarpLevel = $Carp::CarpLevel;
809             $Carp::CarpLevel += _depth();
810             $_[0] =~ s/\s+at\s+\S+Autouse\.pm line \d+\.$//;
811             Carp::croak($_[0]);
812             }
813              
814             # Adaptive debug print generation
815             BEGIN {
816             eval <<'END_DEBUG' if DEBUG;
817              
818             sub _debug {
819             my $args = shift;
820             my $method = !! shift;
821             my $message = shift || '';
822             my @c = caller(1);
823             my $msg = _depth(1) . $c[3];
824             if ( ref $args ) {
825             my @mapped = map { defined $_ ? "'$_'" : 'undef' } @$args;
826             shift @mapped if $method;
827             $msg .= @mapped ? '( ' . ( join ', ', @mapped ) . ' )' : '()';
828             }
829             print "$msg$message\n";
830             }
831              
832             END_DEBUG
833             }
834              
835              
836              
837              
838              
839             #####################################################################
840             # Final Initialisation
841              
842             # The _UPDATE_HOOKS function is intended to turn our hijacking of UNIVERSAL::can
843             # on or off, depending on whether we have any live hooks. The idea being, if we
844             # don't have any live hooks, why bother intercepting UNIVERSAL::can calls?
845             sub _UPDATE_HOOKS () {
846             local $^W = 0;
847             *UNIVERSAL::can = $HOOKS ? \&_can : $ORIGINAL_CAN;
848             *UNIVERSAL::isa = $HOOKS ? \&_isa : $ORIGINAL_ISA;
849             }
850              
851             # The _GLOBAL_HOOKS function turns on the universal autoloader hooks
852             sub _GLOBAL_HOOKS () {
853             return if \&UNIVERSAL::AUTOLOAD == \&_UNIVERSAL_AUTOLOAD;
854              
855             # Overwrite UNIVERSAL::AUTOLOAD and catch any
856             # UNIVERSAL::DESTROY calls so they don't trigger
857             # UNIVERSAL::AUTOLOAD. Anyone handling DESTROY calls
858             # via an AUTOLOAD should be summarily shot.
859             *UNIVERSAL::AUTOLOAD = \&_UNIVERSAL_AUTOLOAD;
860             *UNIVERSAL::DESTROY = \&_UNIVERSAL_DESTROY;
861              
862             # Because this will never go away, we increment $HOOKS such
863             # that it will never be decremented, and thus the
864             # UNIVERSAL::can/isa hijack will never be removed.
865             _UPDATE_HOOKS() unless $HOOKS++;
866             }
867              
868             BEGIN {
869             # Optional integration with prefork.pm (if installed)
870             local $@;
871             eval { require prefork };
872             if ( $@ ) {
873             # prefork is not installed.
874             # Do manual detection of mod_perl
875             $DEVEL = 1 if $ENV{MOD_PERL};
876             } else {
877             # Go into devel mode when prefork is enabled
878             $LOADED{prefork} = 1;
879             local $@;
880             eval "prefork::notify( sub { Class::Autouse->devel(1) } )";
881             die $@ if $@;
882             }
883             }
884              
885             1;
886              
887             __END__