[Summary view] [Print] [Text view]

   1  package Devel::InnerPackage;
   2  
   3  use strict;
   4  use base qw(Exporter);
   5  use vars qw($VERSION @EXPORT_OK);
   6  
   7  $VERSION = '0.3';
   8  @EXPORT_OK = qw(list_packages);
   9  
  10  =pod
  11  
  12  =head1 NAME
  13  
  14  
  15  Devel::InnerPackage - find all the inner packages of a package
  16  
  17  =head1 SYNOPSIS
  18  
  19      use Foo::Bar;
  20      use Devel::innerPackage qw(list_packages);
  21  
  22      my @inner_packages = list_packages('Foo::Bar');
  23  
  24  
  25  =head1 DESCRIPTION
  26  
  27  
  28  Given a file like this
  29  
  30  
  31      package Foo::Bar;
  32  
  33      sub foo {}
  34  
  35  
  36      package Foo::Bar::Quux;
  37  
  38      sub quux {}
  39  
  40      package Foo::Bar::Quirka;
  41  
  42      sub quirka {}
  43  
  44      1;
  45  
  46  then
  47  
  48      list_packages('Foo::Bar');
  49  
  50  will return
  51  
  52      Foo::Bar::Quux
  53      Foo::Bar::Quirka
  54  
  55  =head1 METHODS
  56  
  57  =head2 list_packages <package name>
  58  
  59  Return a list of all inner packages of that package.
  60  
  61  =cut
  62  
  63  sub list_packages {
  64              my $pack = shift; $pack .= "::" unless $pack =~ m!::$!;
  65  
  66              no strict 'refs';
  67              my @packs;
  68              my @stuff = grep !/^(main|)::$/, keys %{$pack};
  69              for my $cand (grep /::$/, @stuff)
  70              {
  71                  $cand =~ s!::$!!;
  72                  my @children = list_packages($pack.$cand);
  73      
  74                  push @packs, "$pack$cand" unless $cand =~ /^::/ ||
  75                      !__PACKAGE__->_loaded($pack.$cand); # or @children;
  76                  push @packs, @children;
  77              }
  78              return grep {$_ !~ /::::ISA::CACHE/} @packs;
  79  }
  80  
  81  ### XXX this is an inlining of the Class-Inspector->loaded()
  82  ### method, but inlined to remove the dependency.
  83  sub _loaded {
  84         my ($class, $name) = @_;
  85  
  86      no strict 'refs';
  87  
  88         # Handle by far the two most common cases
  89         # This is very fast and handles 99% of cases.
  90         return 1 if defined ${"$name}::VERSION"};
  91         return 1 if defined @{"$name}::ISA"};
  92  
  93         # Are there any symbol table entries other than other namespaces
  94         foreach ( keys %{"$name}::"} ) {
  95                 next if substr($_, -2, 2) eq '::';
  96                 return 1 if defined &{"$name}::$_"};
  97         }
  98  
  99         # No functions, and it doesn't have a version, and isn't anything.
 100         # As an absolute last resort, check for an entry in %INC
 101         my $filename = join( '/', split /(?:'|::)/, $name ) . '.pm';
 102         return 1 if defined $INC{$filename};
 103  
 104         '';
 105  }
 106  
 107  
 108  =head1 AUTHOR
 109  
 110  Simon Wistow <simon@thegestalt.org>
 111  
 112  =head1 COPYING
 113  
 114  Copyright, 2005 Simon Wistow
 115  
 116  Distributed under the same terms as Perl itself.
 117  
 118  =head1 BUGS
 119  
 120  None known.
 121  
 122  =cut 
 123  
 124  
 125  
 126  
 127  
 128  1;