File Coverage

blib/lib/Devel/InnerPackage.pm
Criterion Covered Total %
statement 43 43 100.0
branch 13 14 92.8
condition 2 3 66.6
subroutine 8 8 100.0
pod 1 1 100.0
total 67 69 97.1


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