File Coverage

blib/lib/Devel/Symdump.pm
Criterion Covered Total %
statement 0 187 0.0
branch 0 62 0.0
condition 0 46 0.0
subroutine 0 15 0.0
pod 7 7 100.0
total 7 317 2.2


line stmt bran cond sub pod time code
1             package Devel::Symdump;
2              
3             use 5.003;
4             use Carp ();
5             use strict;
6             use vars qw($Defaults $VERSION *ENTRY $MAX_RECURSION);
7              
8             $VERSION = '2.16';
9             $MAX_RECURSION = 97;
10              
11             $Defaults = {
12             'RECURS' => 0,
13             'AUTOLOAD' => {
14             'packages' => 1,
15             'scalars' => 1,
16             'arrays' => 1,
17             'hashes' => 1,
18             'functions' => 1,
19             'ios' => 1,
20             'unknowns' => 1,
21             },
22             'SEEN' => {},
23             };
24              
25             sub rnew {
26 0     0 1   my($class,@packages) = @_;
27             no strict "refs";
28 0           my $self = bless {%${"$class\::Defaults"}}, $class;
  0            
29 0           $self->{RECURS}++;
30 0           $self->_doit(@packages);
31             }
32              
33             sub new {
34 0     0 1   my($class,@packages) = @_;
35             no strict "refs";
36 0           my $self = bless {%${"$class\::Defaults"}}, $class;
  0            
37 0           $self->_doit(@packages);
38             }
39              
40             sub _doit {
41 0     0     my($self,@packages) = @_;
42 0 0         @packages = ("main") unless @packages;
43 0           $self->{RESULT} = $self->_symdump(@packages);
44 0           return $self;
45             }
46              
47             sub _symdump {
48 0     0     my($self,@packages) = @_ ;
49 0           my($key,$val,$num,$pack,@todo,$tmp);
50 0           my $result = {};
51 0           foreach $pack (@packages){
52             no strict;
53 0           while (($key,$val) = each(%{*{"$pack\::"}})) {
  0            
  0            
54 0           my $gotone = 0;
55 0           local(*ENTRY) = $val;
56             #### SCALAR ####
57 0 0 0       if (defined $val && defined *ENTRY{SCALAR}) {
58 0           $result->{$pack}{SCALARS}{$key}++;
59 0           $gotone++;
60             }
61             #### ARRAY ####
62 0 0 0       if (defined $val && defined *ENTRY{ARRAY}) {
63 0           $result->{$pack}{ARRAYS}{$key}++;
64 0           $gotone++;
65             }
66             #### HASH ####
67 0 0 0       if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
      0        
68 0           $result->{$pack}{HASHES}{$key}++;
69 0           $gotone++;
70             }
71             #### PACKAGE ####
72 0 0 0       if (defined $val && defined *ENTRY{HASH} && $key =~ /::$/ &&
      0        
      0        
      0        
73             $key ne "main::" && $key ne "::") {
74 0 0         my($p) = $pack ne "main" ? "$pack\::" : "";
75 0           ($p .= $key) =~ s/::$//;
76 0           $result->{$pack}{PACKAGES}{$p}++;
77 0           $gotone++;
78 0 0         if (++$self->{SEEN}{*$val} > $Devel::Symdump::MAX_RECURSION){
79 0           next;
80             }
81 0           push @todo, $p;
82             }
83             #### FUNCTION ####
84 0 0 0       if (defined $val && defined *ENTRY{CODE}) {
85 0           $result->{$pack}{FUNCTIONS}{$key}++;
86 0           $gotone++;
87             }
88              
89             #### IO #### had to change after 5.003_10
90 0 0         if ($] > 5.003_10){
91 0 0 0       if (defined $val && defined *ENTRY{IO}){ # fileno and telldir...
92 0           $result->{$pack}{IOS}{$key}++;
93 0           $gotone++;
94             }
95             } else {
96             #### FILEHANDLE ####
97 0 0         if (defined fileno(ENTRY)){
    0          
98 0           $result->{$pack}{IOS}{$key}++;
99 0           $gotone++;
100             } elsif (defined telldir(ENTRY)){
101             #### DIRHANDLE ####
102 0           $result->{$pack}{IOS}{$key}++;
103 0           $gotone++;
104             }
105             }
106              
107             #### SOMETHING ELSE ####
108 0 0         unless ($gotone) {
109 0           $result->{$pack}{UNKNOWNS}{$key}++;
110             }
111             }
112             }
113              
114             return (@todo && $self->{RECURS})
115 0 0 0       ? { %$result, %{$self->_symdump(@todo)} }
  0            
116             : $result;
117             }
118              
119             sub _partdump {
120 0     0     my($self,$part)=@_;
121 0           my ($pack, @result);
122 0           my $prepend = "";
123 0           foreach $pack (keys %{$self->{RESULT}}){
  0            
124 0 0         $prepend = "$pack\::" unless $part eq 'PACKAGES';
125 0 0         push @result, map {"$prepend$_"} keys %{$self->{RESULT}{$pack}{$part} || {}};
  0            
  0            
126             }
127 0           return @result;
128             }
129              
130             # this is needed so we don't try to AUTOLOAD the DESTROY method
131       0     sub DESTROY {}
132              
133             sub as_string {
134 0     0 1   my $self = shift;
135 0           my($type,@m);
136 0           for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  0            
137 0           push @m, $type;
138             push @m, "\t" . join "\n\t", map {
139 0           s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg;
  0            
  0            
140 0           $_;
141             } sort $self->_partdump(uc $type);
142             }
143 0           return join "\n", @m;
144             }
145              
146             sub as_HTML {
147 0     0 1   my $self = shift;
148 0           my($type,@m);
149 0           push @m, ""; "; ";
150 0           for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  0            
151 0           push @m, "
$type
152             push @m, "" . join ", ", map {
153 0           s/([\000-\037\177])/ '^' .
  0            
  0            
154             pack('c', ord($1) ^ 64)
155 0           /eg; $_;
156             } sort $self->_partdump(uc $type);
157 0           push @m, "
158             }
159 0           push @m, "
";
160 0           return join "\n", @m;
161             }
162              
163             sub diff {
164 0     0 1   my($self,$second) = @_;
165 0           my($type,@m);
166 0           for $type (sort keys %{$self->{'AUTOLOAD'}}) {
  0            
167 0           my(%first,%second,%all,$symbol);
168 0           foreach $symbol ($self->_partdump(uc $type)){
169 0           $first{$symbol}++;
170 0           $all{$symbol}++;
171             }
172 0           foreach $symbol ($second->_partdump(uc $type)){
173 0           $second{$symbol}++;
174 0           $all{$symbol}++;
175             }
176 0           my(@typediff);
177 0           foreach $symbol (sort keys %all){
178 0 0 0       next if $first{$symbol} && $second{$symbol};
179 0 0         push @typediff, "- $symbol" unless $second{$symbol};
180 0 0         push @typediff, "+ $symbol" unless $first{$symbol};
181             }
182 0           foreach (@typediff) {
183 0           s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg;
  0            
184             }
185 0 0         push @m, $type, @typediff if @typediff;
186             }
187 0           return join "\n", @m;
188             }
189              
190             sub inh_tree {
191 0     0 1   my($self) = @_;
192 0 0 0       return $self->{INHTREE} if ref $self && defined $self->{INHTREE};
193 0           my($inherited_by) = {};
194 0           my($m)="";
195 0           my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays;
196 0           my $isa;
197 0           foreach $isa (sort @isa) {
198 0           $isa =~ s/::ISA$//;
199 0           my($isaisa);
200             no strict 'refs';
201 0           foreach $isaisa (@{"$isa\::ISA"}){
  0            
202 0           $inherited_by->{$isaisa}{$isa}++;
203             }
204             }
205 0           my $item;
206 0           foreach $item (sort keys %$inherited_by) {
207 0           $m .= "$item\n";
208 0           $m .= _inh_tree($item,$inherited_by);
209             }
210 0 0         $self->{INHTREE} = $m if ref $self;
211 0           $m;
212             }
213              
214             sub _inh_tree {
215 0     0     my($package,$href,$depth) = @_;
216 0 0         return unless defined $href;
217 0   0       $depth ||= 0;
218 0           $depth++;
219 0 0         if ($depth > 100){
220 0           warn "Deep recursion in ISA\n";
221 0           return;
222             }
223 0           my($m) = "";
224             # print "DEBUG: package[$package]depth[$depth]\n";
225 0           my $i;
226 0           foreach $i (sort keys %{$href->{$package}}) {
  0            
227 0           $m .= qq{\t} x $depth;
228 0           $m .= qq{$i\n};
229 0           $m .= _inh_tree($i,$href,$depth);
230             }
231 0           $m;
232             }
233              
234             sub isa_tree{
235 0     0 1   my($self) = @_;
236 0 0 0       return $self->{ISATREE} if ref $self && defined $self->{ISATREE};
237 0           my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays;
238 0           my($m) = "";
239 0           my($isa);
240 0           foreach $isa (sort @isa) {
241 0           $isa =~ s/::ISA$//;
242 0           $m .= qq{$isa\n};
243 0           $m .= _isa_tree($isa)
244             }
245 0 0         $self->{ISATREE} = $m if ref $self;
246 0           $m;
247             }
248              
249             sub _isa_tree{
250 0     0     my($package,$depth) = @_;
251 0   0       $depth ||= 0;
252 0           $depth++;
253 0 0         if ($depth > 100){
254 0           warn "Deep recursion in ISA\n";
255 0           return;
256             }
257 0           my($m) = "";
258             # print "DEBUG: package[$package]depth[$depth]\n";
259 0           my $isaisa;
260             no strict 'refs';
261 0           foreach $isaisa (@{"$package\::ISA"}) {
  0            
262 0           $m .= qq{\t} x $depth;
263 0           $m .= qq{$isaisa\n};
264 0           $m .= _isa_tree($isaisa,$depth);
265             }
266 0           $m;
267             }
268              
269             AUTOLOAD {
270 0     0     my($self,@packages) = @_;
271 0 0         unless (ref $self) {
272 0           $self = $self->new(@packages);
273             }
274             no strict "vars";
275 0           (my $auto = $AUTOLOAD) =~ s/.*:://;
276              
277 0           $auto =~ s/(file|dir)handles/ios/;
278 0           my $compat = $1;
279              
280 0 0         unless ($self->{'AUTOLOAD'}{$auto}) {
281 0           Carp::croak("invalid Devel::Symdump method: $auto()");
282             }
283              
284 0           my @syms = $self->_partdump(uc $auto);
285 0 0         if (defined $compat) {
286             no strict 'refs';
287 0           local $^W; # bleadperl@26631 introduced an io warning here
288 0 0         if ($compat eq "file") {
289 0           @syms = grep { defined(fileno($_)) } @syms;
  0            
290             } else {
291 0           @syms = grep { _is_dirhandle($_) } @syms;
  0            
292             }
293             }
294 0           return @syms; # make sure now it gets context right
295             }
296              
297             use Config ();
298             use constant HAVE_TELLDIR => $Config::Config{d_telldir};
299             sub _is_dirhandle {
300 0     0     my ($glob) = @_;
301 0           if ( HAVE_TELLDIR ) {
302 0           return defined(telldir($glob));
303             }
304             else {
305             if ( !ref $glob ) {
306             no strict 'refs';
307             $glob = \*{$glob};
308             }
309             require B;
310             my $obj = B::svref_2object($glob);
311             return if !$obj || !eval{ $obj->IO; $obj->IO->IoTYPE; 1 };
312             my $mode = $obj->IO->IoTYPE;
313             return $mode eq "\0" ? 1 : 0;
314             }
315             }
316              
317             1;
318              
319             __END__