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   71963 use strict;
  42         84  
  42         1809  
4 42     42   397 use base qw(Exporter);
  42         365  
  42         5350  
5 42     42   239 use vars qw($VERSION @EXPORT_OK);
  42         89  
  42         3729  
6              
7 42     42   48955 use if $] > 5.017, 'deprecate';
  42         405  
  42         261  
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 <package name>
59              
60             Return a list of all inner packages of that package.
61              
62             =cut
63              
64             sub list_packages {
65 249 50   249 1 2443 my $pack = shift; $pack .= "::" unless $pack =~ m!::$!;
  249         2031  
66              
67 42     42   95482 no strict 'refs';
  42         86  
  42         12918  
68 249         296 my @packs;
69 249         314 my @stuff = grep !/^(main|)::$/, keys %{$pack};
  249         1663  
70 249         1231 for my $cand (grep /::$/, @stuff)
71             {
72 96         377 $cand =~ s!::$!!;
73 96         340 my @children = list_packages($pack.$cand);
74            
75 96 100 66     585 push @packs, "$pack$cand" unless $cand =~ /^::/ ||
76             !__PACKAGE__->_loaded($pack.$cand); # or @children;
77 96         233 push @packs, @children;
78             }
79 249         1774 return grep {$_ !~ /::(::ISA::CACHE|SUPER)/} @packs;
  104         562  
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 96     96   158 my ($class, $name) = @_;
86              
87 42     42   286 no strict 'refs';
  42         87  
  42         10625  
88              
89             # Handle by far the two most common cases
90             # This is very fast and handles 99% of cases.
91 96 100       120 return 1 if defined ${"${name}::VERSION"};
  96         701  
92 66 100       78 return 1 if @{"${name}::ISA"};
  66         453  
93              
94             # Are there any symbol table entries other than other namespaces
95 60         82 foreach ( keys %{"${name}::"} ) {
  60         224  
96 115 100       308 next if substr($_, -2, 2) eq '::';
97 110 100       117 return 1 if defined &{"${name}::$_"};
  110         642  
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         368 my $filename = join( '/', split /(?:'|::)/, $name ) . '.pm';
103 17 100       109 return 1 if defined $INC{$filename};
104              
105 5         24 '';
106             }
107              
108              
109             =head1 AUTHOR
110              
111             Simon Wistow <simon@thegestalt.org>
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;