local-lib5/lib/perl5/Class/Inspector.pm

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