← Back to branch summary

~ubuntu-branches/ubuntu/lucid/libmodule-info-perl/lucid

« back to all changes in this revision

Viewing changes to lib/B/Module/Info.pm

  • Committer: Bazaar Package Importer
  • Author(s): Jay Bonci
  • Date: 2003-10-06 10:51:04 UTC
  • Revision ID: james.westby@ubuntu.com-20031006105104-1b67d55zyyay6jvo
Tags: upstream-0.24
Import upstream version 0.24

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/B/Module/Info.pm
 
1
package B::Module::Info;
 
2
 
 
3
$VERSION = '0.24';
 
4
 
 
5
use B;
 
6
use B::Utils qw(walkoptree_filtered walkoptree_simple
 
7
                opgrep all_roots);
 
8
@B::Utils::bad_stashes = qw();  # give us everything.
 
9
 
 
10
{
 
11
    # From: Roland Walker <walker@ncbi.nlm.nih.gov>
 
12
    # "Syntax OK" may land inside output and render it unusable
 
13
    my $oldfh = select STDERR; $| = 1; # STDERR is unbuffered, but just in case
 
14
    select STDOUT; $| = 1;
 
15
    select $oldfh;
 
16
}
 
17
 
 
18
my $the_file = $0; # when walking all subroutines, you need to skip
 
19
                   # the ones in other modules
 
20
 
 
21
sub state_change {
 
22
    return opgrep {name => [qw(nextstate dbstate setstate)]}, @_
 
23
}
 
24
 
 
25
my $cur_pack;
 
26
sub state_call {
 
27
    my($op) = shift;
 
28
    my $pack = $op->stashpv;
 
29
    print "$pack\n" if !defined($cur_pack) || $pack ne $cur_pack;
 
30
    $cur_pack = $pack;
 
31
}
 
32
 
 
33
 
 
34
sub filtered_roots {
 
35
    my %roots = all_roots;
 
36
    my %filtered_roots = ();
 
37
    while( my($name, $op) = each %roots ) {
 
38
        next if $name eq '__MAIN__';
 
39
        $filtered_roots{$name} = $op;
 
40
    }
 
41
    return %filtered_roots;
 
42
}
 
43
 
 
44
 
 
45
=head2 roots_cv_pairs
 
46
 
 
47
Returns a list of pairs, each containing a root with the relative
 
48
B::CV object; this list includes B::main_root/cv.
 
49
 
 
50
=cut
 
51
 
 
52
sub roots_cv_pairs {
 
53
    my %roots = filtered_roots;
 
54
    my @roots = ( [ B::main_root, B::main_cv ],
 
55
                  map { [ $roots{$_},
 
56
                          B::svref_2object(\&{$_}) ] }
 
57
                  keys %roots );
 
58
}
 
59
 
 
60
 
 
61
my %modes = (
 
62
             packages => sub { 
 
63
                 walkoptree_filtered(B::main_root,
 
64
                                     \&state_change,
 
65
                                     \&state_call );
 
66
             },
 
67
             subroutines => sub {
 
68
                 my %roots = filtered_roots();
 
69
                 while( my($name, $op) = each %roots ) {
 
70
                     local($File, $Start, $End);
 
71
                     walkoptree_simple($op, \&sub_info);
 
72
                     print "$name at \"$File\" from $Start to $End\n";
 
73
                 }
 
74
             },
 
75
             modules_used => sub {
 
76
                 # begin_av is an undocumented B function.
 
77
                 # note: if module hasn't any BEGIN block,
 
78
                 #       begin_av will be a B::SPECIAL
 
79
                 my @arr = B::begin_av->isa('B::SPECIAL') ?
 
80
                           () :
 
81
                           B::begin_av->ARRAY;
 
82
                 foreach my $begin_cv (@arr) {
 
83
                     my $root = $begin_cv->ROOT;
 
84
                     local $CurCV = $begin_cv;
 
85
 
 
86
                     next unless $begin_cv->FILE eq $the_file;
 
87
                     # cheat otherwise show_require guard prevents display
 
88
                     local $B::Utils::file = $begin_cv->FILE;
 
89
                     local $B::Utils::line = $begin_cv->START->line;
 
90
 
 
91
                     # this is from $ENV{PERL5OPT}, skip it
 
92
                     next if $B::Utils::line == 0;
 
93
 
 
94
                     my $lineseq = $root->first;
 
95
                     next if $lineseq->name ne 'lineseq';
 
96
 
 
97
                     my $req_op = $lineseq->first->sibling;
 
98
                     if( $req_op->name eq 'require' ) {
 
99
                         my $module;
 
100
                         if( $req_op->first->private & B::OPpCONST_BARE ) {
 
101
                             $module = const_sv($req_op->first)->PV;
 
102
                             $module =~ s[/][::]g;
 
103
                             $module =~ s/.pm$//;
 
104
                         }
 
105
                         else {
 
106
                             # if it is not bare it can't be an "use"
 
107
                             show_require($req_op);
 
108
                             next;
 
109
                         }
 
110
 
 
111
                         printf "use %s (%s) at \"%s\" line %s\n",
 
112
                             $module,
 
113
                             get_required_version($req_op, $module),
 
114
                             $begin_cv->FILE,
 
115
                             $begin_cv->START->line;
 
116
                     }
 
117
                     # it can't be an use, scan the optree
 
118
                     else {
 
119
                         walkoptree_filtered($root,
 
120
                                     \&is_require,
 
121
                                     \&show_require,
 
122
                                    );
 
123
                     }
 
124
                 }
 
125
 
 
126
                 {
 
127
                     foreach my $p ( roots_cv_pairs ) {
 
128
                         local $CurCV = $p->[1];
 
129
                         walkoptree_filtered($p->[0],
 
130
                                     \&is_require,
 
131
                                     \&show_require,
 
132
                                    );
 
133
                     }
 
134
                 }
 
135
             },
 
136
             subs_called => sub {
 
137
                 my %roots = filtered_roots;
 
138
                 foreach my $p ( roots_cv_pairs ) {
 
139
                     local $CurCV = $p->[1];
 
140
                     walkoptree_filtered($p->[0],
 
141
                                         \&sub_call,
 
142
                                         \&sub_check );
 
143
                 }
 
144
             }
 
145
            );
 
146
 
 
147
 
 
148
sub const_sv {
 
149
    my $op = shift;
 
150
    my $sv = $op->sv if $op->can('sv');
 
151
    # the constant could be in the pad (under useithreads)
 
152
    $sv = padval($op->targ) unless $$sv;
 
153
    return $sv;
 
154
}
 
155
 
 
156
# Don't do this for regexes
 
157
sub unback {
 
158
    my($str) = @_;
 
159
    $str =~ s/\\/\\\\/g;
 
160
    return $str;
 
161
}
 
162
 
 
163
sub const {
 
164
    my $sv = shift;
 
165
    if (B::class($sv) eq "SPECIAL") {
 
166
        return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
 
167
    } elsif (B::class($sv) eq "NULL") {
 
168
        return 'undef';
 
169
    } elsif ($sv->FLAGS & B::SVf_IOK) {
 
170
        return $sv->int_value;
 
171
    } elsif ($sv->FLAGS & B::SVf_NOK) {
 
172
        # try the default stringification
 
173
        my $r = "".$sv->NV;
 
174
        if ($r =~ /e/) {
 
175
            # If it's in scientific notation, we might have lost information
 
176
            return sprintf("%.20e", $sv->NV);
 
177
        }
 
178
        return $r;
 
179
    } elsif ($sv->FLAGS & B::SVf_ROK && $sv->can("RV")) {
 
180
        return "\\(" . B::const($sv->RV) . ")"; # constant folded
 
181
    } elsif ($sv->FLAGS & B::SVf_POK) {
 
182
        my $str = $sv->PV;
 
183
        if ($str =~ /[^ -~]/) { # ASCII for non-printing
 
184
            return single_delim("qq", '"', uninterp escape_str unback $str);
 
185
        } else {
 
186
            return single_delim("q", "'", unback $str);
 
187
        }
 
188
    } else {
 
189
        return "undef";
 
190
    }
 
191
}
 
192
 
 
193
 
 
194
sub single_delim {
 
195
    my($q, $default, $str) = @_;
 
196
    return "$default$str$default" if $default and index($str, $default) == -1;
 
197
    my($succeed, $delim);
 
198
    ($succeed, $str) = balanced_delim($str);
 
199
    return "$q$str" if $succeed;
 
200
    for $delim ('/', '"', '#') {
 
201
        return "$q$delim" . $str . $delim if index($str, $delim) == -1;
 
202
    }
 
203
    if ($default) {
 
204
        $str =~ s/$default/\\$default/g;
 
205
        return "$default$str$default";
 
206
    } else {
 
207
        $str =~ s[/][\\/]g;
 
208
        return "$q/$str/";
 
209
    }
 
210
}
 
211
 
 
212
 
 
213
sub padval {
 
214
    my $targ = shift;
 
215
    return (($CurCV->PADLIST->ARRAY)[1]->ARRAY)[$targ];
 
216
}
 
217
 
 
218
 
 
219
sub sub_info {
 
220
    $File = undef if $File eq '__none__';
 
221
    $File  ||= $B::Utils::file;
 
222
    $Start = $B::Utils::line if !$Start || $B::Utils::line < $Start;
 
223
    $End   = $B::Utils::line if !$End   || $B::Utils::line > $End;
 
224
}
 
225
 
 
226
sub is_begin {
 
227
    my($op) = shift;
 
228
    my $name = $op->GV;
 
229
    print $name;
 
230
    return $name eq 'BEGIN';
 
231
}
 
232
 
 
233
sub begin_is_use {
 
234
    my($op) = shift;
 
235
    print "Saw begin\n";
 
236
}
 
237
 
 
238
 
 
239
sub grep_magic {
 
240
    my($pvmg, $type) = @_;
 
241
    my $magic = $pvmg->MAGIC;
 
242
 
 
243
    while ($$magic) {
 
244
        return $magic if $magic->TYPE eq $type;
 
245
    }
 
246
 
 
247
    return $magic; # false
 
248
}
 
249
 
 
250
sub get_required_version {
 
251
    my($req_op, $module) = (shift, shift);
 
252
 
 
253
    my $version;
 
254
    my $version_op = $req_op->sibling;
 
255
    return if B::class($version_op) eq 'NULL';
 
256
    if ($version_op->name eq 'lineseq') {
 
257
        # We have a version parameter; skip nextstate &
 
258
        # pushmark
 
259
        my $constop = $version_op->first->next->next;
 
260
 
 
261
        return '' unless const_sv($constop)->PV eq $module;
 
262
        $constop = $constop->sibling;
 
263
        $version = const_sv($constop);
 
264
        my $class = B::class($version);
 
265
        my $magic;
 
266
        $version = $class eq 'IV'   ? $version->int_value :
 
267
                   $class eq 'NV'   ? $version->NV :
 
268
                  ($class eq 'PVMG' && ($magic = grep_magic($version, 'V'))
 
269
                        && $$magic) ? 'v' . $magic->PTR :
 
270
                 ((($class eq 'PVNV' && $] < 5.009) || $class eq 'PVMG')
 
271
                       && length($version->PV)) ?
 
272
                     'v' . join('.', map(ord,
 
273
                                         split(//,
 
274
                                               $version->PV)
 
275
                                        ))         :
 
276
                   $class eq 'PVIV' ? $version->int_value :
 
277
                                      $version->NV;
 
278
 
 
279
        $constop = $constop->sibling;
 
280
        return '' if $constop->name ne "method_named";
 
281
        return '' if const_sv($constop)->PV ne "VERSION";
 
282
    }
 
283
 
 
284
    return $version;
 
285
}
 
286
 
 
287
 
 
288
sub is_require {
 
289
    B::class($_[0]) ne 'NULL' && $_[0]->name eq 'require';
 
290
}
 
291
 
 
292
sub show_require {
 
293
    return unless $B::Utils::file eq $the_file;
 
294
    my($op) = shift;
 
295
 
 
296
    my($name, $bare);
 
297
    if( B::class($op) eq "UNOP" and $op->first->name eq 'const'
 
298
        and $op->first->private & B::OPpCONST_BARE ) {
 
299
        $bare = 'bare';
 
300
        $name = const_sv($op->first)->PV;
 
301
    }
 
302
    else {
 
303
        $bare = 'not bare';
 
304
        if ($op->flags & B::OPf_KIDS) {
 
305
            my $kid = $op->first;
 
306
            if (defined prototype("CORE::$name") 
 
307
                && prototype("CORE::$name") =~ /^;?\*/
 
308
                && $kid->name eq "rv2gv") {
 
309
                $kid = $kid->first;
 
310
            }
 
311
 
 
312
            my $sv = const_sv($kid);
 
313
            return unless defined $sv && !$sv->isa('B::NULL');
 
314
            $name   = $sv->isa("B::NV") ? $sv->NV : 0;
 
315
            $name ||= $sv->isa("B::PV") ? $sv->PV : '';
 
316
            $name ||= $sv->IV;
 
317
        }
 
318
        else {
 
319
            $name = "";
 
320
        }
 
321
    }
 
322
    printf "require %s %s at line %d\n", $bare, $name, $B::Utils::line;
 
323
}
 
324
 
 
325
 
 
326
sub compile {
 
327
    my($mode) = shift;
 
328
 
 
329
    return $modes{$mode};
 
330
}
 
331
 
 
332
 
 
333
sub sub_call {
 
334
    B::class($_[0]) ne 'NULL' && $_[0]->name eq 'entersub';
 
335
}
 
336
 
 
337
sub sub_check {
 
338
    my($op) = shift;
 
339
 
 
340
    unless( $op->name eq 'entersub' ) {
 
341
        warn "sub_check only works with entersub ops";
 
342
        return;
 
343
    }
 
344
 
 
345
    my @kids = $op->kids;
 
346
 
 
347
    # static method call
 
348
    if( my($kid) = grep $_->name eq 'method_named', @kids ) {
 
349
        my $class = _class_or_object_method(@kids);
 
350
        printf "%s method call to %s%s at \"%s\" line %d\n", 
 
351
          $class ? "class" : "object",
 
352
          const_sv($kid)->PV,
 
353
          $class ? " via $class" : '',
 
354
          $B::Utils::file, $B::Utils::line;
 
355
    }
 
356
    # dynamic method call
 
357
    elsif( my($kid) = grep $_->name eq 'method', @kids ) {
 
358
        my $class = _class_or_object_method(@kids);
 
359
        printf "dynamic %s method call%s at \"%s\" line %d\n",
 
360
          $class ? "class" : "object",
 
361
          $class ? " via $class" : '',
 
362
          $B::Utils::file, $B::Utils::line;
 
363
    }
 
364
    # function call
 
365
    else {
 
366
        my($name_op) = grep($_->name eq 'gv', @kids);
 
367
        if( $name_op ) {
 
368
            my $gv = gv_or_padgv($name_op);
 
369
            printf "function call to %s at \"%s\" line %d\n", 
 
370
              $gv->NAME, $B::Utils::file, $B::Utils::line;
 
371
        }
 
372
        else {
 
373
            printf "function call using symbolic ref at \"%s\" line %d\n",
 
374
              $B::Utils::file, $B::Utils::line;
 
375
        }
 
376
    }
 
377
}
 
378
 
 
379
 
 
380
sub gv_or_padgv {
 
381
#    my $self = shift;
 
382
    my $op = shift;
 
383
    if ($op->isa("B::PADOP")) {
 
384
        return padval($op->padix);
 
385
    }
 
386
    else { # class($op) eq "SVOP"
 
387
        return $op->gv;
 
388
    }
 
389
}
 
390
 
 
391
 
 
392
sub _class_or_object_method {
 
393
    my @kids = @_;
 
394
 
 
395
    my $class;
 
396
    my($classop) = $kids[1];
 
397
    if( $classop->name eq 'const' ) {
 
398
        $class = const_sv($classop)->PV;
 
399
    }
 
400
 
 
401
    return $class;
 
402
}
 
403
 
 
404
 
 
405
1;