lib/Devel/InnerPackage.pm

   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;