File Coverage

inc/Class/Inspector.pm
Criterion Covered Total %
statement 72 175 41.1
branch 18 92 19.6
condition 0 7 0.0
subroutine 10 23 43.5
pod 10 12 83.3
total 110 309 35.6


line stmt bran cond sub pod time code
1             #line 1
2             package Class::Inspector;
3              
4             #line 40
5              
6             # Load Overhead: 236k
7              
8             # We don't want to use strict refs, since we do a lot of things in here
9             # that arn't strict refs friendly.
10             use strict qw{vars subs};
11             use File::Spec ();
12              
13             # Globals
14             use vars qw{$VERSION $RE_IDENT $RE_CLASS $UNIX};
15             BEGIN {
16             $VERSION = '1.13';
17              
18             # Predefine some regexs
19             $RE_IDENT = qr/\A[^\W\d]\w*\z/s;
20             $RE_CLASS = qr/\A[^\W\d]\w*(?:(?:'|::)[^\W\d]\w*)*\z/s;
21              
22             # Are we on Unix?
23             $UNIX = !! ( $File::Spec::ISA[0] eq 'File::Spec::Unix' );
24             }
25              
26              
27              
28              
29              
30             #####################################################################
31             # Basic Methods
32              
33             #line 80
34              
35             sub installed {
36             my $class = shift;
37             !! ($class->loaded_filename($_[0]) or $class->resolved_filename($_[0]));
38             }
39              
40             #line 104
41              
42             sub loaded {
43             my $class = shift;
44             my $name = $class->_class(shift) or return undef;
45 1     1   12 $class->_loaded($name);
  1         9  
  1         15  
46 1     1   15 }
  1         9  
  1         9  
47              
48             sub _loaded {
49 1     1   15 my ($class, $name) = @_;
  1         8  
  1         119  
50              
51 1     1   15 # Handle by far the two most common cases
52             # This is very fast and handles 99% of cases.
53             return 1 if defined ${"${name}::VERSION"};
54 1         13 return 1 if defined @{"${name}::ISA"};
55 1         12  
56             # Are there any symbol table entries other than other namespaces
57             foreach ( keys %{"${name}::"} ) {
58 1         13 next if substr($_, -2, 2) eq '::';
59             return 1 if defined &{"${name}::$_"};
60             }
61              
62             # No functions, and it doesn't have a version, and isn't anything.
63             # As an absolute last resort, check for an entry in %INC
64             my $filename = $class->_inc_filename($name);
65             return 1 if defined $INC{$filename};
66              
67             '';
68             }
69              
70             #line 150
71              
72             sub filename {
73             my $class = shift;
74             my $name = $class->_class(shift) or return undef;
75             File::Spec->catfile( split /(?:'|::)/, $name ) . '.pm';
76             }
77              
78             #line 176
79              
80             sub resolved_filename {
81             my $class = shift;
82 0     0 1 0 my $filename = $class->_inc_filename(shift) or return undef;
83 0   0     0 my @try_first = @_;
84              
85             # Look through the @INC path to find the file
86             foreach ( @try_first, @INC ) {
87             my $full = "$_/$filename";
88             next unless -e $full;
89             return $UNIX ? $full : $class->_inc_to_local($full);
90             }
91              
92             # File not found
93             '';
94             }
95              
96             #line 205
97              
98             sub loaded_filename {
99             my $class = shift;
100             my $filename = $class->_inc_filename(shift);
101             $UNIX ? $INC{$filename} : $class->_inc_to_local($INC{$filename});
102             }
103              
104              
105              
106 10     10 1 92  
107 10 50       104  
108 10         108 #####################################################################
109             # Sub Related Methods
110              
111             #line 232
112 10     10   95  
113             sub functions {
114             my $class = shift;
115             my $name = $class->_class(shift) or return undef;
116 10 50       79 return undef unless $class->loaded( $name );
  10         182  
117 0 0       0  
  0         0  
118             # Get all the CODE symbol table entries
119             my @functions = sort grep { /$RE_IDENT/o }
120 0         0 grep { defined &{"${name}::$_"} }
  0         0  
121 0 0       0 keys %{"${name}::"};
122 0 0       0 \@functions;
  0         0  
123             }
124              
125             #line 258
126              
127 0         0 sub function_refs {
128 0 0       0 my $class = shift;
129             my $name = $class->_class(shift) or return undef;
130 0         0 return undef unless $class->loaded( $name );
131              
132             # Get all the CODE symbol table entries, but return
133             # the actual CODE refs this time.
134             my @functions = map { \&{"${name}::$_"} }
135             sort grep { /$RE_IDENT/o }
136             grep { defined &{"${name}::$_"} }
137             keys %{"${name}::"};
138             \@functions;
139             }
140              
141             #line 287
142              
143             sub function_exists {
144             my $class = shift;
145             my $name = $class->_class( shift ) or return undef;
146             my $function = shift or return undef;
147              
148             # Only works if the class is loaded
149             return undef unless $class->loaded( $name );
150              
151             # Does the GLOB exist and its CODE part exist
152 0     0 1 0 defined &{"${name}::$function"};
153 0 0       0 }
154 0         0  
155             #line 366
156              
157             sub methods {
158             my $class = shift;
159             my $name = $class->_class( shift ) or return undef;
160             my @arguments = map { lc $_ } @_;
161              
162             # Process the arguments to determine the options
163             my %options = ();
164             foreach ( @arguments ) {
165             if ( $_ eq 'public' ) {
166             # Only get public methods
167             return undef if $options{private};
168             $options{public} = 1;
169              
170             } elsif ( $_ eq 'private' ) {
171             # Only get private methods
172             return undef if $options{public};
173             $options{private} = 1;
174              
175             } elsif ( $_ eq 'full' ) {
176             # Return the full method name
177             return undef if $options{expanded};
178 0     0 1 0 $options{full} = 1;
179 0 0       0  
180 0         0 } elsif ( $_ eq 'expanded' ) {
181             # Returns class, method and function ref
182             return undef if $options{full};
183 0         0 $options{expanded} = 1;
184 0         0  
185 0 0       0 } else {
186 0 0       0 # Unknown or unsupported options
187             return undef;
188             }
189             }
190 0         0  
191             # Only works if the class is loaded
192             return undef unless $class->loaded( $name );
193              
194             # Get the super path ( not including UNIVERSAL )
195             # Rather than using Class::ISA, we'll use an inlined version
196             # that implements the same basic algorithm.
197             my @path = ();
198             my @queue = ( $name );
199             my %seen = ( $name => 1 );
200             while ( my $cl = shift @queue ) {
201             push @path, $cl;
202             unshift @queue, grep { ! $seen{$_}++ }
203             map { s/^::/main::/; s/\'/::/g; $_ }
204             ( @{"${cl}::ISA"} );
205             }
206              
207 0     0 1 0 # Find and merge the function names across the entire super path.
208 0         0 # Sort alphabetically and return.
209 0 0       0 my %methods = ();
210             foreach my $namespace ( @path ) {
211             my @functions = grep { ! $methods{$_} }
212             grep { /$RE_IDENT/o }
213             grep { defined &{"${namespace}::$_"} }
214             keys %{"${namespace}::"};
215             foreach ( @functions ) {
216             $methods{$_} = $namespace;
217             }
218             }
219              
220             # Filter to public or private methods if needed
221             my @methodlist = sort keys %methods;
222             @methodlist = grep { ! /^\_/ } @methodlist if $options{public};
223             @methodlist = grep { /^\_/ } @methodlist if $options{private};
224              
225             # Return in the correct format
226             @methodlist = map { "$methods{$_}::$_" } @methodlist if $options{full};
227             @methodlist = map {
228             [ "$methods{$_}::$_", $methods{$_}, $_, \&{"$methods{$_}::$_"} ]
229             } @methodlist if $options{expanded};
230              
231             \@methodlist;
232             }
233              
234 0     0 1 0  
235 0 0       0  
236 0 0       0  
237              
238             #####################################################################
239 0         0 # Search Methods
  0         0  
240 0         0  
  0         0  
241 0         0 #line 467
242 0         0  
243             sub subclasses {
244             my $class = shift;
245             my $name = $class->_class( shift ) or return undef;
246              
247             # Prepare the search queue
248             my @found = ();
249             my @queue = grep { $_ ne 'main' } $class->_subnames('');
250             while ( @queue ) {
251             my $c = shift(@queue); # c for class
252             if ( $class->_loaded($c) ) {
253             # At least one person has managed to misengineer
254             # a situation in which ->isa could die, even if the
255             # class is real. Trap these cases and just skip
256             # over that (bizarre) class. That would at limit
257             # problems with finding subclasses to only the
258             # modules that have broken ->isa implementation.
259             eval {
260 0     0 1 0 if ( $c->isa($name) ) {
261 0 0       0 # Add to the found list, but don't add the class itself
262 0 0       0 push @found, $c unless $c eq $name;
263             }
264             };
265             }
266 0         0  
  0         0  
  0         0  
267 0         0 # Add any child namespaces to the head of the queue.
268 0         0 # This keeps the queue length shorted, and allows us
  0         0  
269 0         0 # not to have to do another sort at the end.
270 0         0 unshift @queue, map { "${c}::$_" } $class->_subnames($c);
271             }
272              
273             @found ? \@found : '';
274             }
275              
276             sub _subnames {
277             my ($class, $name) = @_;
278             return sort
279             grep {
280             substr($_, -2, 2, '') eq '::'
281             and
282             /$RE_IDENT/o
283             }
284             keys %{"${name}::"};
285             }
286              
287              
288              
289 0     0 1 0  
290 0 0       0  
291 0 0       0 #####################################################################
292             # Children Related Methods
293              
294 0 0       0 # These can go undocumented for now, until I decide if its best to
295             # just search the children in namespace only, or if I should do it via
296             # the file system.
297 0         0  
  0         0  
298             # Find all the loaded classes below us
299             sub children {
300             my $class = shift;
301             my $name = $class->_class(shift) or return ();
302              
303             # Find all the Foo:: elements in our symbol table
304             no strict 'refs';
305             map { "${name}::$_" } sort grep { s/::$// } keys %{"${name}::"};
306             }
307              
308             # As above, but recursively
309             sub recursive_children {
310             my $class = shift;
311             my $name = $class->_class(shift) or return ();
312             my @children = ( $name );
313              
314             # Do the search using a nicer, more memory efficient
315             # variant of actual recursion.
316             my $i = 0;
317             no strict 'refs';
318             while ( my $namespace = $children[$i++] ) {
319             push @children, map { "${namespace}::$_" }
320             grep { ! /^::/ } # Ignore things like ::ISA::CACHE::
321             grep { s/::$// }
322             keys %{"${namespace}::"};
323             }
324              
325             sort @children;
326             }
327              
328              
329              
330              
331              
332             #####################################################################
333             # Private Methods
334              
335             # Checks and expands ( if needed ) a class name
336             sub _class {
337             my $class = shift;
338             my $name = shift or return '';
339              
340             # Handle main shorthand
341             return 'main' if $name eq '::';
342             $name =~ s/\A::/main::/;
343              
344             # Check the class name is valid
345             $name =~ /$RE_CLASS/o ? $name : '';
346             }
347              
348             # Create a INC-specific filename, which always uses '/'
349             # regardless of platform.
350             sub _inc_filename {
351             my $class = shift;
352             my $name = $class->_class(shift) or return undef;
353             join( '/', split /(?:'|::)/, $name ) . '.pm';
354             }
355              
356             # Convert INC-specific file name to local file name
357             sub _inc_to_local {
358             my $class = shift;
359              
360             # Shortcut in the Unix case
361             return $_[0] if $UNIX;
362              
363             # Get the INC filename and convert
364             my $inc_name = shift or return undef;
365             my ($vol, $dir, $file) = File::Spec::Unix->splitpath( $inc_name );
366             $dir = File::Spec->catdir( File::Spec::Unix->splitdir( $dir || "" ) );
367             File::Spec->catpath( $vol, $dir, $file || "" );
368 4     4 1 39 }
369 4 50       49  
370 4         40 1;
  8         89  
371              
372             #line 630
373 4         88