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