File Coverage

blib/lib/Class/Inspector.pm
Criterion Covered Total %
statement 154 178 86.5
branch 71 92 77.2
condition 2 7 28.6
subroutine 21 24 87.5
pod 10 12 83.3
total 258 313 82.4


line stmt bran cond sub pod time code
1             package Class::Inspector;
2              
3             =pod
4            
5             =head1 NAME
6            
7             Class::Inspector - Get information about a class and its structure
8            
9             =head1 SYNOPSIS
10            
11             use Class::Inspector;
12            
13             # Is a class installed and/or loaded
14             Class::Inspector->installed( 'Foo::Class' );
15             Class::Inspector->loaded( 'Foo::Class' );
16            
17             # Filename related information
18             Class::Inspector->filename( 'Foo::Class' );
19             Class::Inspector->resolved_filename( 'Foo::Class' );
20            
21             # Get subroutine related information
22             Class::Inspector->functions( 'Foo::Class' );
23             Class::Inspector->function_refs( 'Foo::Class' );
24             Class::Inspector->function_exists( 'Foo::Class', 'bar' );
25             Class::Inspector->methods( 'Foo::Class', 'full', 'public' );
26            
27             # Find all loaded subclasses or something
28             Class::Inspector->subclasses( 'Foo::Class' );
29            
30             =head1 DESCRIPTION
31            
32             Class::Inspector allows you to get information about a loaded class. Most or
33             all of this information can be found in other ways, but they arn't always
34             very friendly, and usually involve a relatively high level of Perl wizardry,
35             or strange and unusual looking code. Class::Inspector attempts to provide
36             an easier, more friendly interface to this information.
37            
38             =head1 METHODS
39            
40             =cut
41              
42 2     2   59 use 5.005;
  2         29  
  2         20  
43             # We don't want to use strict refs, since we do a lot of things in here
44             # that arn't strict refs friendly.
45 2     2   31 use strict qw{vars subs};
  2         20  
  2         84  
46 2     2   68 use File::Spec ();
  2         19  
  2         20  
47              
48             # Globals
49 2     2   28 use vars qw{$VERSION $RE_IDENT $RE_CLASS $UNIX};
  2         18  
  2         31  
50             BEGIN {
51 2     2   30 $VERSION = '1.16';
52              
53             # Predefine some regexs
54 2         171 $RE_IDENT = qr/\A[^\W\d]\w*\z/s;
55 2         22 $RE_CLASS = qr/\A[^\W\d]\w*(?:(?:'|::)[^\W\d]\w*)*\z/s;
56              
57             # Are we on something Unix-like?
58 2         26 $UNIX = !! ( $File::Spec::ISA[0] eq 'File::Spec::Unix' );
59             }
60              
61              
62              
63              
64              
65             #####################################################################
66             # Basic Methods
67              
68             =pod
69            
70             =head2 installed $class
71            
72             The C<installed> static method tries to determine if a class is installed
73             on the machine, or at least available to Perl. It does this by wrapping
74             around C<resolved_filename>.
75            
76             Returns true if installed/available, false if the class is not installed,
77             or C<undef> if the class name is invalid.
78            
79             =cut
80              
81             sub installed {
82 2     2 1 19 my $class = shift;
83 2   66     24 !! ($class->loaded_filename($_[0]) or $class->resolved_filename($_[0]));
84             }
85              
86             =pod
87            
88             =head2 loaded $class
89            
90             The C<loaded> static method tries to determine if a class is loaded by
91             looking for symbol table entries.
92            
93             This method it uses to determine this will work even if the class does not
94             have its own file, but is contained inside a single file with multiple
95             classes in it. Even in the case of some sort of run-time loading class
96             being used, these typically leave some trace in the symbol table, so an
97             L<Autoload> or L<Class::Autouse>-based class should correctly appear
98             loaded.
99            
100             Returns true if the class is loaded, false if not, or C<undef> if the
101             class name is invalid.
102            
103             =cut
104              
105             sub loaded {
106 28     28 1 271 my $class = shift;
107 28 50       312 my $name = $class->_class(shift) or return undef;
108 28         301 $class->_loaded($name);
109             }
110              
111             sub _loaded {
112 688     688   7673 my ($class, $name) = @_;
113              
114             # Handle by far the two most common cases
115             # This is very fast and handles 99% of cases.
116 688 100       7205 return 1 if defined ${"${name}::VERSION"};
  688         9447  
117 430 100       3716 return 1 if defined @{"${name}::ISA"};
  430         5769  
118              
119             # Are there any symbol table entries other than other namespaces
120 288         2454 foreach ( keys %{"${name}::"} ) {
  288         7107  
121 467 100       7591 next if substr($_, -2, 2) eq '::';
122 311 100       2757 return 1 if defined &{"${name}::$_"};
  311         4191  
123             }
124              
125             # No functions, and it doesn't have a version, and isn't anything.
126             # As an absolute last resort, check for an entry in %INC
127 208         4121 my $filename = $class->_inc_filename($name);
128 208 50       2186 return 1 if defined $INC{$filename};
129              
130 208         2509 '';
131             }
132              
133             =pod
134            
135             =head2 filename $class
136            
137             For a given class, returns the base filename for the class. This will NOT
138             be a fully resolved filename, just the part of the filename BELOW the
139             C<@INC> entry.
140            
141             print Class->filename( 'Foo::Bar' );
142             > Foo/Bar.pm
143            
144             This filename will be returned with the right seperator for the local
145             platform, and should work on all platforms.
146            
147             Returns the filename on success or C<undef> if the class name is invalid.
148            
149             =cut
150              
151             sub filename {
152 1     1 1 11 my $class = shift;
153 1 50       13 my $name = $class->_class(shift) or return undef;
154 1         29 File::Spec->catfile( split /(?:'|::)/, $name ) . '.pm';
155             }
156              
157             =pod
158            
159             =head2 resolved_filename $class, @try_first
160            
161             For a given class, the C<resolved_filename> static method returns the fully
162             resolved filename for a class. That is, the file that the class would be
163             loaded from.
164            
165             This is not nescesarily the file that the class WAS loaded from, as the
166             value returned is determined each time it runs, and the C<@INC> include
167             path may change.
168            
169             To get the actual file for a loaded class, see the C<loaded_filename>
170             method.
171            
172             Returns the filename for the class, or C<undef> if the class name is
173             invalid.
174            
175             =cut
176              
177             sub resolved_filename {
178 2     2 1 20 my $class = shift;
179 2 50       23 my $filename = $class->_inc_filename(shift) or return undef;
180 2         21 my @try_first = @_;
181              
182             # Look through the @INC path to find the file
183 2         22 foreach ( @try_first, @INC ) {
184 23         233 my $full = "$_/$filename";
185 23 100       564 next unless -e $full;
186 1 50       21 return $UNIX ? $full : $class->_inc_to_local($full);
187             }
188              
189             # File not found
190 1         20 '';
191             }
192              
193             =pod
194            
195             =head2 loaded_filename $class
196            
197             For a given loaded class, the C<loaded_filename> static method determines
198             (via the C<%INC> hash) the name of the file that it was originally loaded
199             from.
200            
201             Returns a resolved file path, or false if the class did not have it's own
202             file.
203            
204             =cut
205              
206             sub loaded_filename {
207 3     3 1 36 my $class = shift;
208 3         32 my $filename = $class->_inc_filename(shift);
209 3 50       58 $UNIX ? $INC{$filename} : $class->_inc_to_local($INC{$filename});
210             }
211              
212              
213              
214              
215              
216             #####################################################################
217             # Sub Related Methods
218              
219             =pod
220            
221             =head2 functions $class
222            
223             For a loaded class, the C<functions> static method returns a list of the
224             names of all the functions in the classes immediate namespace.
225            
226             Note that this is not the METHODS of the class, just the functions.
227            
228             Returns a reference to an array of the function names on success, or C<undef>
229             if the class name is invalid or the class is not loaded.
230            
231             =cut
232              
233             sub functions {
234 3     3 1 44 my $class = shift;
235 3 50       33 my $name = $class->_class(shift) or return undef;
236 3 100       33 return undef unless $class->loaded( $name );
237              
238             # Get all the CODE symbol table entries
239 17         329 my @functions = sort grep { /$RE_IDENT/o }
  26         344  
240 26         198 grep { defined &{"${name}::$_"} }
  1         26  
241 1         10 keys %{"${name}::"};
242 1         21 \@functions;
243             }
244              
245             =pod
246            
247             =head2 function_refs $class
248            
249             For a loaded class, the C<function_refs> static method returns references to
250             all the functions in the classes immediate namespace.
251            
252             Note that this is not the METHODS of the class, just the functions.
253            
254             Returns a reference to an array of C<CODE> refs of the functions on
255             success, or C<undef> if the class is not loaded.
256            
257             =cut
258              
259             sub function_refs {
260 1     1 1 12 my $class = shift;
261 1 50       12 my $name = $class->_class(shift) or return undef;
262 1 50       12 return undef unless $class->loaded( $name );
263              
264             # Get all the CODE symbol table entries, but return
265             # the actual CODE refs this time.
266 17         203 my @functions = map { \&{"${name}::$_"} }
  17         1276  
  17         195  
267 26         295 sort grep { /$RE_IDENT/o }
268 26         201 grep { defined &{"${name}::$_"} }
  1         29  
269 1         11 keys %{"${name}::"};
270 1         31 \@functions;
271             }
272              
273             =pod
274            
275             =head2 function_exists $class, $function
276            
277             Given a class and function name the C<function_exists> static method will
278             check to see if the function exists in the class.
279            
280             Note that this is as a function, not as a method. To see if a method
281             exists for a class, use the C<can> method for any class or object.
282            
283             Returns true if the function exists, false if not, or C<undef> if the
284             class or function name are invalid, or the class is not loaded.
285            
286             =cut
287              
288             sub function_exists {
289 4     4 1 39 my $class = shift;
290 4 50       44 my $name = $class->_class( shift ) or return undef;
291 4 100       47 my $function = shift or return undef;
292              
293             # Only works if the class is loaded
294 3 100       31 return undef unless $class->loaded( $name );
295              
296             # Does the GLOB exist and its CODE part exist
297 2         17 defined &{"${name}::$function"};
  2         36  
298             }
299              
300             =pod
301            
302             =head2 methods $class, @options
303            
304             For a given class name, the C<methods> static method will returns ALL
305             the methods available to that class. This includes all methods available
306             from every class up the class' C<@ISA> tree.
307            
308             Returns a reference to an array of the names of all the available methods
309             on success, or C<undef> if the class name is invalid or the class is not
310             loaded.
311            
312             A number of options are available to the C<methods> method that will alter
313             the results returned. These should be listed after the class name, in any
314             order.
315            
316             # Only get public methods
317             my $method = Class::Inspector->methods( 'My::Class', 'public' );
318            
319             =over 4
320            
321             =item public
322            
323             The C<public> option will return only 'public' methods, as defined by the Perl
324             convention of prepending an underscore to any 'private' methods. The C<public>
325             option will effectively remove any methods that start with an underscore.
326            
327             =item private
328            
329             The C<private> options will return only 'private' methods, as defined by the
330             Perl convention of prepending an underscore to an private methods. The
331             C<private> option will effectively remove an method that do not start with an
332             underscore.
333            
334             B<Note: The C<public> and C<private> options are mutually exclusive>
335            
336             =item full
337            
338             C<methods> normally returns just the method name. Supplying the C<full> option
339             will cause the methods to be returned as the full names. That is, instead of
340             returning C<[ 'method1', 'method2', 'method3' ]>, you would instead get
341             C<[ 'Class::method1', 'AnotherClass::method2', 'Class::method3' ]>.
342            
343             =item expanded
344            
345             The C<expanded> option will cause a lot more information about method to be
346             returned. Instead of just the method name, you will instead get an array
347             reference containing the method name as a single combined name, ala C<full>,
348             the seperate class and method, and a CODE ref to the actual function ( if
349             available ). Please note that the function reference is not guarenteed to
350             be available. C<Class::Inspector> is intended at some later time, work
351             with modules that have some some of common run-time loader in place ( e.g
352             C<Autoloader> or C<Class::Autouse> for example.
353            
354             The response from C<methods( 'Class', 'expanded' )> would look something like
355             the following.
356            
357             [
358             [ 'Class::method1', 'Class', 'method1', \&Class::method1 ],
359             [ 'Another::method2', 'Another', 'method2', \&Another::method2 ],
360             [ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ],
361             ]
362            
363             =back
364            
365             =cut
366              
367             sub methods {
368 22     22 1 391 my $class = shift;
369 22 50       231 my $name = $class->_class( shift ) or return undef;
370 22         202 my @arguments = map { lc $_ } @_;
  20         250  
371              
372             # Process the arguments to determine the options
373 22         199 my %options = ();
374 22         271 foreach ( @arguments ) {
375 20 100       862 if ( $_ eq 'public' ) {
    100          
    100          
    50          
376             # Only get public methods
377 6 100       69 return undef if $options{private};
378 5         53 $options{public} = 1;
379              
380             } elsif ( $_ eq 'private' ) {
381             # Only get private methods
382 4 100       52 return undef if $options{public};
383 3         32 $options{private} = 1;
384              
385             } elsif ( $_ eq 'full' ) {
386             # Return the full method name
387 4 100       51 return undef if $options{expanded};
388 3         34 $options{full} = 1;
389              
390             } elsif ( $_ eq 'expanded' ) {
391             # Returns class, method and function ref
392 6 100       101 return undef if $options{full};
393 5         83 $options{expanded} = 1;
394              
395             } else {
396             # Unknown or unsupported options
397 0         0 return undef;
398             }
399             }
400              
401             # Only works if the class is loaded
402 18 100       193 return undef unless $class->loaded( $name );
403              
404             # Get the super path ( not including UNIVERSAL )
405             # Rather than using Class::ISA, we'll use an inlined version
406             # that implements the same basic algorithm.
407 12         103 my @path = ();
408 12         109 my @queue = ( $name );
409 12         120 my %seen = ( $name => 1 );
410 12         128 while ( my $cl = shift @queue ) {
411 18         714 push @path, $cl;
412 6         90 unshift @queue, grep { ! $seen{$_}++ }
  6         53  
413 6         51 map { s/^::/main::/; s/\'/::/g; $_ }
  6         60  
  18         234  
414 18         151 ( @{"${cl}::ISA"} );
415             }
416              
417             # Find and merge the function names across the entire super path.
418             # Sort alphabetically and return.
419 12         107 my %methods = ();
420 12         158 foreach my $namespace ( @path ) {
421 234         2472 my @functions = grep { ! $methods{$_} }
  234         2415  
422 372         4601 grep { /$RE_IDENT/o }
423 372         3533 grep { defined &{"${namespace}::$_"} }
  18         449  
424 18         940 keys %{"${namespace}::"};
425 18         351 foreach ( @functions ) {
426 228         2443 $methods{$_} = $namespace;
427             }
428             }
429              
430             # Filter to public or private methods if needed
431 12         448 my @methodlist = sort keys %methods;
432 12 100       161 @methodlist = grep { ! /^\_/ } @methodlist if $options{public};
  76         737  
433 12 100       134 @methodlist = grep { /^\_/ } @methodlist if $options{private};
  38         2253  
434              
435             # Return in the correct format
436 12 100       240 @methodlist = map { "$methods{$_}::$_" } @methodlist if $options{full};
  38         471  
437 64         996 @methodlist = map {
438 12 100       126 [ "$methods{$_}::$_", $methods{$_}, $_, \&{"$methods{$_}::$_"} ]
  64         620  
439             } @methodlist if $options{expanded};
440              
441 12         265 \@methodlist;
442             }
443              
444              
445              
446              
447              
448             #####################################################################
449             # Search Methods
450              
451             =pod
452            
453             =head2 subclasses $class
454            
455             The C<subclasses> static method will search then entire namespace (and thus
456             B<all> currently loaded classes) to find all classes that are subclasses
457             of the class provided as a the parameter.
458            
459             The actual test will be done by calling C<isa> on the class as a static
460             method. (i.e. C<My::Class-E<gt>isa($class)>.
461            
462             Returns a reference to a list of the loaded classes that match the class
463             provided, or false is none match, or C<undef> if the class name provided
464             is invalid.
465            
466             =cut
467              
468             sub subclasses {
469 5     5 1 64 my $class = shift;
470 5 100       55 my $name = $class->_class( shift ) or return undef;
471              
472             # Prepare the search queue
473 4         94 my @found = ();
474 4         47 my @queue = grep { $_ ne 'main' } $class->_subnames('');
  240         2676  
475 4         298 while ( @queue ) {
476 660         7369 my $c = shift(@queue); # c for class
477 660 100       9600 if ( $class->_loaded($c) ) {
478             # At least one person has managed to misengineer
479             # a situation in which ->isa could die, even if the
480             # class is real. Trap these cases and just skip
481             # over that (bizarre) class. That would at limit
482             # problems with finding subclasses to only the
483             # modules that have broken ->isa implementation.
484 463         4774 eval {
485 463 100       10431 if ( $c->isa($name) ) {
486             # Add to the found list, but don't add the class itself
487 8 100       104 push @found, $c unless $c eq $name;
488             }
489             };
490             }
491              
492             # Add any child namespaces to the head of the queue.
493             # This keeps the queue length shorted, and allows us
494             # not to have to do another sort at the end.
495 660         7298 unshift @queue, map { "${c}::$_" } $class->_subnames($c);
  424         6222  
496             }
497              
498 4 100       63 @found ? \@found : '';
499             }
500              
501             sub _subnames {
502 664     664   5988 my ($class, $name) = @_;
503             return sort
504 11388 100       181086 grep {
505 664         13867 substr($_, -2, 2, '') eq '::'
506             and
507             /$RE_IDENT/o
508             }
509 664         10792 keys %{"${name}::"};
510             }
511              
512              
513              
514              
515              
516             #####################################################################
517             # Children Related Methods
518              
519             # These can go undocumented for now, until I decide if its best to
520             # just search the children in namespace only, or if I should do it via
521             # the file system.
522              
523             # Find all the loaded classes below us
524             sub children {
525 0     0 0 0 my $class = shift;
526 0 0       0 my $name = $class->_class(shift) or return ();
527              
528             # Find all the Foo:: elements in our symbol table
529 2     2   45 no strict 'refs';
  2         23  
  2         44  
530 0         0 map { "${name}::$_" } sort grep { s/::$// } keys %{"${name}::"};
  0         0  
  0         0  
  0         0  
531             }
532              
533             # As above, but recursively
534             sub recursive_children {
535 0     0 0 0 my $class = shift;
536 0 0       0 my $name = $class->_class(shift) or return ();
537 0         0 my @children = ( $name );
538              
539             # Do the search using a nicer, more memory efficient
540             # variant of actual recursion.
541 0         0 my $i = 0;
542 2     2   31 no strict 'refs';
  2         18  
  2         25  
543 0         0 while ( my $namespace = $children[$i++] ) {
544 0         0 push @children, map { "${namespace}::$_" }
  0         0  
545 0         0 grep { ! /^::/ } # Ignore things like ::ISA::CACHE::
546 0         0 grep { s/::$// }
547 0         0 keys %{"${namespace}::"};
548             }
549              
550 0         0 sort @children;
551             }
552              
553              
554              
555              
556              
557             #####################################################################
558             # Private Methods
559              
560             # Checks and expands ( if needed ) a class name
561             sub _class {
562 286     286   2634 my $class = shift;
563 286 100       3073 my $name = shift or return '';
564              
565             # Handle main shorthand
566 284 100       2721 return 'main' if $name eq '::';
567 283         2473 $name =~ s/\A::/main::/;
568              
569             # Check the class name is valid
570 283 100       6093 $name =~ /$RE_CLASS/o ? $name : '';
571             }
572              
573             # Create a INC-specific filename, which always uses '/'
574             # regardless of platform.
575             sub _inc_filename {
576 214     214   1880 my $class = shift;
577 214 50       2283 my $name = $class->_class(shift) or return undef;
578 214         3369 join( '/', split /(?:'|::)/, $name ) . '.pm';
579             }
580              
581             # Convert INC-specific file name to local file name
582             sub _inc_to_local {
583 0     0     my $class = shift;
584              
585             # Shortcut in the Unix case
586 0 0         return $_[0] if $UNIX;
587              
588             # Get the INC filename and convert
589 0 0         my $inc_name = shift or return undef;
590 0           my ($vol, $dir, $file) = File::Spec::Unix->splitpath( $inc_name );
591 0   0       $dir = File::Spec->catdir( File::Spec::Unix->splitdir( $dir || "" ) );
592 0   0       File::Spec->catpath( $vol, $dir, $file || "" );
593             }
594              
595             1;
596              
597             =pod
598            
599             =head1 TO DO
600            
601             - Adding Class::Inspector::Functions
602            
603             =head1 SUPPORT
604            
605             Bugs should be reported via the CPAN bug tracker
606            
607             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class-Inspector>
608            
609             For other issues, or commercial enhancement or support, contact the author.
610            
611             =head1 AUTHOR
612            
613             Adam Kennedy E<lt>cpan@ali.asE<gt>
614            
615             =head1 SEE ALSO
616            
617             L<http://ali.as/>, L<Class::Handle>
618            
619             =head1 COPYRIGHT
620            
621             Copyright (c) 2002 - 2006 Adam Kennedy. All rights reserved.
622            
623             This program is free software; you can redistribute
624             it and/or modify it under the same terms as Perl itself.
625            
626             The full text of the license can be found in the
627             LICENSE file included with this module.
628            
629             =cut
630