Commit | Line | Data |
---|---|---|
b98aa5f6 JB |
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; |