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