← Back to branch summary

~ubuntu-branches/ubuntu/wily/libmodule-info-perl/wily-proposed

« back to all changes in this revision

Viewing changes to .pc/whatis-entry.patch/lib/B/Module/Info.pm

  • Committer: Package Import Robot
  • Author(s): Florian Schlichting
  • Date: 2013-09-21 01:03:12 UTC
  • mfrom: (1.2.6)
  • Revision ID: package-import@ubuntu.com-20130921010312-0s045y2k0dbc35og
Tags: 0.35-1
* Import Upstream version 0.35
* Drop all patches, applied upstream

Show diffs side-by-side

added added

removed removed

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