Xref.pm

   1 ######################################################################
   2 package Sepia::Xref;
   3
   4 our $VERSION = '0.56';
   5
   6 =head1 NAME
   7
   8 Sepia::Xref - Generates cross reference database for use by Perl programs.
   9
  10 =head1 SYNOPSIS
  11
  12     use Sepia::Xref qw(rebuild defs callers);
  13
  14     rebuild;
  15     for (defs 'foo') {
  16         printf "%s:%d: sub %s\::foo() defined\n", @{$_}[0..2];
  17     }
  18
  19     for (callers 'foo') {
  20         printf "%s:%d: sub foo() called by %s\::%s().\n", @{$_}[0..3];
  21     }
  22
  23 =head1 DESCRIPTION
  24
  25 C<Sepia::Xref> is intended as a programmatic interface to the
  26 information supplied by L<B::Xref>.  It is intended to be a component
  27 for interactive Perl development, with other packages providing a
  28 friendly interface to the raw information it extracts.  C<B::Xref>
  29 could be seen as an example of this sort of user-level tool, if it
  30 weren't for the fact that this module was created later, and stole
  31 most of its code.
  32
  33 =cut
  34
  35 use strict;
  36 use Config;
  37 use Cwd 'abs_path';
  38 use B qw(peekop class comppadlist main_start svref_2object walksymtable
  39          OPpLVAL_INTRO SVf_POK OPpOUR_INTRO OPf_MOD OPpDEREF_HV OPpDEREF_AV
  40          cstring);
  41 # use Sepia '_apropos_re';
  42 require Sepia;
  43 *_apropos_re = *Sepia::_apropos_re;
  44
  45 =head2 Variables
  46
  47 =over
  48
  49 =item C<%call>
  50
  51 A map of subs to call locations and callers
  52
  53 =item C<%callby>
  54
  55 A map of subs to subs called.
  56
  57 =item C<%var_use>
  58
  59 A map of global/package variables to uses.
  60
  61 =item C<%var_def>
  62
  63 A map of global/package variables to definitions (usually empty, since
  64 it only picks up local (...) declarations.
  65
  66 =back
  67
  68 =cut
  69
  70 our %call;
  71 our %callby;
  72 our %var_def;
  73 our %var_use;
  74
  75 require Exporter;
  76 our @ISA = qw(Exporter);
  77 my @most = qw(redefined forget rebuild callers callees
  78               var_defs var_uses
  79               mod_subs mod_files mod_decls mod_apropos
  80               apropos var_apropos file_apropos);
  81 our @EXPORT_OK = (@most,
  82     qw(xref_definitions xref_object xref_main
  83        %call %callby %var_use %var_def));
  84
  85 our %EXPORT_TAGS =
  86     (':all' => \@EXPORT_OK,
  87      ':most' => \@most);
  88
  89 ######################################################################
  90 ## Xref state variables:
  91
  92 sub UNKNOWN { ["?", "?", "?"] }
  93
  94 my @pad;                        # lexicals in current pad
  95                                 # as ["(lexical)", type, name]
  96 my @padval;
  97 our %done;                      # keyed by $$op: set when each $op is done
  98 my $top = UNKNOWN;              # shadows top element of stack as
  99                                 # [pack, type, name] (pack can be "(lexical)")
 100 our $file;                      # shadows current filename
 101 my $line;                       # shadows current line number
 102 our $subname;                   # shadows current sub name
 103 our @todo = ();                 # List of CVs that need processing
 104 my $lastclass;                  # last bareword seen after entersub.
 105
 106 our $DEBUG = 0;
 107 sub dprint {
 108     my $type = shift;
 109     my $res = "@_";
 110     $res =~ s/%//g;             # XXX: work around EPL's misuse of (message)
 111     print STDERR "@_" if $DEBUG =~ /$type/;
 112 }
 113
 114 my %code = (intro => "i", used => "",
 115             subdef => "s", subused => "&",
 116             formdef => "f", meth => "->");
 117
 118
 119 =item C<guess_module_file($pack, $ofile)>
 120
 121 XXX: it turns out that rooting around trying to figure out the file
 122 ourselves is more reliable than what we grab from the op.  Are we
 123 doing this wrong?
 124
 125 =cut
 126
 127 sub guess_module_file {
 128     my ($pack, $ofile) = @_;
 129     my $file;
 130
 131     # XXX: is this why we get the bogus defs?
 132     return undef if $ofile =~ /Exporter\.pm$/;
 133     # Try for standard translation in %INC:
 134     (my $fn = $pack) =~ s/::/\//g;
 135     if (exists $INC{"$fn.pm"}) {
 136         return $INC{"$fn.pm"};
 137     }
 138
 139     # Try what they told us:
 140     chomp $ofile;
 141     return $ofile if -f $ofile;
 142
 143     # Try "parent" packages:
 144     while ($fn =~ s|/?[^/]+$|| && !$file) {
 145         $file ||= $INC{"$fn.pm"};
 146     }
 147
 148     if ($file && $file !~ /^\//) {
 149         $file = abs_path($file);
 150     }
 151
 152     if (!$file || !-f $file) {
 153         undef $file;
 154     }
 155     $file;
 156 }
 157
 158 # XXX: should weed through the code below so it only generates decent
 159 # package names, but this will fix it for now.
 160 sub realpack {
 161     my $p = shift;
 162     if (!defined $p || $p eq '?' || $p eq '(method)') {
 163         return undef;
 164     } elsif ($p eq '') {
 165         return 'main';
 166     } else {
 167         return $p;
 168     }
 169 }
 170
 171 # Turn a possibly-qualified name into a package and basename.
 172 sub split_name {
 173     local $_ = shift;
 174     my ($p, $s);
 175     if (/^(.*)::(.+)$/) {
 176         ($p, $s) = ($1, $2);
 177     } else {
 178         ($p, $s) = ('main', $_);
 179     }
 180     undef $s if $s eq '?';
 181     ($p, $s);
 182 }
 183
 184 sub process {
 185     my ($var, $event) = @_;
 186     my ($pack, $type, $name) = @$var;
 187     $pack = realpack($pack);
 188     dprint 'loud', "Processing $event: @$var ($subname)";
 189     if ($type eq "*") {
 190         if ($event eq "used" || $event eq 'set') {
 191             return;
 192         } elsif ($event eq "subused") {
 193             $type = "&";
 194         } elsif ($event eq "meth") {
 195             $type = '->';
 196         }
 197     }
 198     $type =~ s/(.)\*$/$1/g;
 199     $file = guess_module_file($pack, $file);
 200
 201     if (($type eq '&' || $type eq '->') && $subname ne '(definitions)') {
 202         # Handle caller/callee relations
 203         my ($spack, $sname) = split_name($subname);
 204
 205         $call{$name}{$pack}{$subname} = 1;
 206
 207         $callby{$sname}{$spack}{"$pack\::$name"} = 1;
 208     } elsif ($type eq 's' || $subname eq '(definitions)') {
 209         # definition
 210     } elsif ($name !~ /^[\x00-\x1f^] | ^\d+$ | ^[\W_]$
 211                        | ^(?:ENV|INC|STD(?:IN|OUT|ERR)|SIG)$ /x
 212              && realpack($pack)) {
 213         # Variables, but ignore specials and lexicals
 214         my ($spack, $sname) = split_name($subname);
 215         if ($event eq 'intro') {
 216             $var_def{$name}{$pack} =
 217             { file => $file,
 218               package => $spack,
 219               line => $line,
 220               sub => $sname,
 221             };
 222         } elsif ($event eq 'used' || $event eq 'set') {
 223             push @{$var_use{$name}{$pack}},
 224             { file => $file,
 225               package => $spack,
 226               line => $line,
 227               sub => $sname,
 228               assign => ($event eq 'set'),
 229             };
 230         } else {
 231             dprint 'ignore', "Ignoring var event $event";
 232         }
 233     } else {
 234         dprint 'ignore', "Ignoring $type event $event";
 235     }
 236 }
 237
 238 sub load_pad {
 239     my $padlist = shift;
 240     my ($namelistav, $vallistav, @namelist, $ix);
 241     @pad = ();
 242     @padval = ();
 243     return if class($padlist) eq "SPECIAL";
 244     ($namelistav,$vallistav) = $padlist->ARRAY;
 245     @namelist = $namelistav->ARRAY;
 246     for ($ix = 1; $ix < @namelist; $ix++) {
 247         my $namesv = $namelist[$ix];
 248         next if class($namesv) eq "SPECIAL";
 249         my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
 250         $pad[$ix] = [undef, $type, $name];
 251     }
 252     if ($Config{useithreads}) {
 253         my (@vallist);
 254         @vallist = $vallistav->ARRAY;
 255         for ($ix = 1; $ix < @vallist; $ix++) {
 256             my $valsv = $vallist[$ix];
 257             next unless class($valsv) eq "GV";
 258             # these pad GVs don't have corresponding names, so same @pad
 259             # array can be used without collisions
 260             $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
 261         }
 262     }
 263     @padval = $vallistav->ARRAY;
 264 }
 265
 266 sub xref {
 267     my $start = shift;
 268     my $op;
 269     for ($op = $start; $$op; $op = $op->next) {
 270         last if $done{$$op}++;
 271         my $opname = $op->name;
 272         if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
 273             xref($op->other);
 274         } elsif ($opname eq "match" || $opname eq "subst") {
 275             xref($op->pmreplstart);
 276         } elsif ($opname eq "substcont") {
 277             xref($op->other->pmreplstart);
 278             $op = $op->other;
 279             redo;
 280         } elsif ($opname eq "enterloop") {
 281             xref($op->redoop);
 282             xref($op->nextop);
 283             xref($op->lastop);
 284         } elsif ($opname eq "subst") {
 285             xref($op->pmreplstart);
 286         } else {
 287             no strict 'refs';
 288 #             print STDERR $opname;
 289             my $ppname = "pp_$opname";
 290             &$ppname($op) if defined(&$ppname);
 291         }
 292     }
 293 }
 294
 295 sub xref_cv {
 296     my $cv = shift;
 297     my $pack = $cv->GV->STASH->NAME;
 298     local $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
 299     load_pad($cv->PADLIST);
 300     xref($cv->START);
 301 }
 302
 303 sub xref_object {
 304     my $cvref = shift;
 305     local (@todo, %done);
 306     my $cv = svref_2object($cvref);
 307     xref_cv($cv);
 308     dprint 'todo', "todo = (@todo)";
 309     my $gv = $cv->GV;
 310     process([$gv->STASH->NAME, '&', $gv->NAME], 'subdef');
 311 }
 312
 313 sub xref_main {
 314     $subname = "(main)";
 315     load_pad(comppadlist);
 316     xref(main_start);
 317     while (@todo) {
 318         xref_cv(shift @todo);
 319     }
 320 }
 321
 322 sub pp_pushmark {
 323     my $op = shift;
 324     my ($class, $meth);
 325     if (($class = $op->next)->name eq 'const') {
 326         my $sv = $class->sv;
 327         my ($classname, $methname);
 328         # constant could be in the pad (under useithreads)
 329         if (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) {
 330             $classname = $sv->PV;
 331         } else {
 332             my $pv = $padval[$class->targ];
 333             if (class($pv) =~ /^PV/ && class($sv) eq 'SPECIAL'
 334                 ## bareword flag -- should use this?
 335 #                 && ($op->private & 64)
 336                ) {
 337                 $classname = $pv->PV;
 338             }
 339         }
 340         $lastclass = $classname;
 341     }
 342 }
 343
 344 sub pp_nextstate {
 345     my $op = shift;
 346     $file = $op->file;
 347     die "pp_nextstate: $file" if $file =~ /::/;
 348     $line = $op->line;
 349     $top = UNKNOWN;
 350 }
 351
 352 sub use_type($) {
 353     my ($op) = @_;
 354     if ($op->private & (OPpLVAL_INTRO | OPpOUR_INTRO)) {
 355         'intro';
 356     } elsif ($op->flags & OPf_MOD
 357              && !($op->private & (OPpDEREF_HV | OPpDEREF_AV))) {
 358         'set';
 359     } else {
 360         'used';
 361     }
 362 }
 363
 364 sub pp_padsv {
 365     my $op = shift;
 366      $top = $pad[$op->targ];
 367 #     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 368 }
 369
 370 sub pp_padav { pp_padsv(@_) }
 371 sub pp_padhv { pp_padsv(@_) }
 372
 373 sub deref {
 374     my ($op, $var, $as) = @_;
 375     $var->[1] = $as . $var->[1];
 376     process($var, use_type $op);
 377 }
 378
 379 sub pp_rv2cv { deref(shift, $top, "&"); }
 380 sub pp_rv2hv { deref(shift, $top, "%"); }
 381 sub pp_rv2sv { deref(shift, $top, "\$"); }
 382 sub pp_rv2av { deref(shift, $top, "\@"); }
 383 sub pp_rv2gv { deref(shift, $top, "*"); }
 384
 385 sub pp_gvsv {
 386     my $op = shift;
 387     my $gv;
 388     if ($Config{useithreads}) {
 389         $top = $pad[$op->padix];
 390         $top = UNKNOWN unless $top;
 391         $top->[1] = '$';
 392     }
 393     else {
 394         $gv = $op->gv;
 395         $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
 396     }
 397     process($top, use_type $op);
 398 }
 399
 400 sub pp_gv {
 401     my $op = shift;
 402     my $gv;
 403     if ($Config{useithreads}) {
 404         $top = $pad[$op->padix];
 405         $top = UNKNOWN unless $top;
 406         $top->[1] = '*';
 407     }
 408     else {
 409         $gv = $op->gv;
 410         $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
 411     }
 412     process($top, use_type $op);
 413 }
 414
 415 sub pp_method {
 416     my $op = shift;
 417     $top = [$lastclass || "(method)", "->".$top->[1], $top->[2]];
 418     dprint 'method', "pp_method($top->[1])";
 419     undef $lastclass;
 420 }
 421
 422 sub pp_method_named {
 423     use Data::Dumper;
 424     my $op = shift;
 425     my $sv = $op->sv;
 426     my $pviv = $padval[$op->targ];
 427     if ($pviv && class($pviv) =~ /^PV/) {
 428         my $name = $pviv->PV;
 429         dprint 'method_named', $op->targ.": $name";
 430         undef $top->[2] if $top->[2] eq '?';
 431         $top = [$lastclass || "(method)", '->', $name];
 432         undef $lastclass;
 433     } else {
 434         warn "method_named: wtf: sizeof padval = ".@padval;
 435     }
 436 }
 437
 438 sub pp_entersub {
 439     my $op = shift;
 440     if ($top->[1] =~ /^(?:m$|->)/) {
 441         dprint 'method', "call to (@$top) from $subname";
 442         process($top, "meth");
 443     } else {
 444         process($top, "subused");
 445     }
 446     undef $lastclass;
 447     $top = UNKNOWN;
 448 }
 449
 450 #
 451 # Stuff for cross referencing definitions of variables and subs
 452 #
 453
 454 sub B::GV::xref {
 455     my $gv = shift;
 456     my $cv = $gv->CV;
 457     $file = $gv->FILE;
 458     # XXX: sometimes the "file" is a module.  Why?
 459     $line = $gv->LINE;
 460     if ($$cv) {
 461         #return if $done{$$cv}++;
 462         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 463         push(@todo, $cv);
 464     }
 465     my $form = $gv->FORM;
 466     if ($$form) {
 467         return if $done{$$form}++;
 468         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 469     }
 470 }
 471
 472 sub xref_definitions {
 473     my ($pack, %exclude);
 474     $subname = "(definitions)";
 475     foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 476                       strict vars FileHandle Exporter Carp PerlIO::Layer
 477                       attributes utf8 warnings)) {
 478         $exclude{$pack."::"} = 1;
 479     }
 480     no strict qw(vars refs);
 481     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 482 }
 483
 484 =head2 Functions
 485
 486 =over
 487
 488 =item C<rebuild()>
 489
 490 Rebuild the Xref database.
 491
 492 =cut
 493
 494 sub rebuild {
 495     %call = (); %callby = ();
 496     %var_def = (); %var_use = ();
 497     local (@todo, %done);
 498     xref_definitions;
 499     xref_main;
 500     1;
 501 }
 502
 503 sub unmention {
 504     my ($h, $K, $V, $pack) = @_;
 505     dprint 'unmention', "Unmentioning $K => $V";
 506     while (my ($k, $v) = each %$h) {
 507         while (my ($k2, $v2) = each %$v) {
 508             if (ref $v2 eq 'ARRAY') {
 509                 $v->{$k2} = [grep {
 510                     $_->{$K} ne $V || !$pack || $pack ne $_->{package}
 511                 } @$v2];
 512                 delete $v->{$k2} unless @{$v->{$k2}};
 513             } else {
 514                 delete $v->{$k2} if $k2 eq $V;
 515             }
 516         }
 517         delete $h->{$k} unless keys %{$h->{$k}};
 518     }
 519 }
 520
 521 sub unmention_sub {
 522     my ($h, $sub, $pack) = @_;
 523     dprint 'unmention', "Unmentioning $pack\::$sub";
 524     if ($pack) {
 525         delete $h->{$sub}{$pack};
 526         delete $h->{$sub} unless keys %{$h->{$sub}};
 527     } else {
 528         delete $h->{$sub};
 529     }
 530 }
 531
 532 =item C<forget($func [, $mod])>
 533
 534 Forget that C<$func> was defined.
 535
 536 =cut
 537
 538 sub forget {
 539     my ($obj, $pack) = @_;
 540     unmention_sub \%callby, @_;
 541     unmention \%call, 'sub', @_;
 542     unmention \%var_use, 'sub', @_;
 543     unmention \%var_def, 'sub', @_;
 544 }
 545
 546 =item C<redefined($func [, $pack])>
 547
 548 Recompute xref info for C<$func>, or C<$pack::$func> if C<$pack> given.
 549
 550 =cut
 551
 552 sub redefined {
 553     forget @_;
 554     {
 555         no strict 'refs';
 556         my ($sub, $pack) = @_;
 557         $pack ||= 'main';
 558         $sub = $pack eq 'main' ? $sub : "$pack\::$sub";
 559         local $subname = '(definitions)';
 560         xref_object \&$sub;
 561     }
 562 }
 563
 564 ######################################################################
 565 # Apropos and definition-finding:
 566
 567 sub _ret_list {
 568     my ($l, $mod, $sub) = @_;
 569     my @r;
 570     if ($mod) {
 571         @r = keys %{$l->{$mod}};
 572     } else {
 573         my %h;
 574         @h{keys %$_} = 1 for values %$l;
 575         @r = keys %h;
 576     }
 577     @r = sort @r;
 578     return wantarray ? @r : \@r;
 579 }
 580
 581 =item C<callers($func)>
 582
 583 List callers of C<$func>.
 584
 585 =cut
 586
 587 sub callers {
 588     my $f = shift;
 589     if ($f =~ /^(.*)::([^:]+)$/) {
 590         unshift @_, $1;
 591         $f = $2;
 592     }
 593     return _ret_list $call{$f}, @_;
 594 }
 595
 596 =item C<callees($func)>
 597
 598 List callees of C<$func>.
 599
 600 =cut
 601
 602 sub callees {
 603     my $f = shift;
 604     if ($f =~ /^(.*::)([^:]+)$/) {
 605         unshift @_, $1;
 606         $f = $2;
 607     }
 608     _ret_list $callby{$f}, @_;
 609 }
 610
 611 =item C<var_defs($var)>
 612
 613 Find locations where C<$var> is defined.
 614
 615 =cut
 616
 617 sub var_defs {
 618     my $v = shift;
 619     $v =~ s/.*:://;
 620     return _ret_list $var_def{$v}, @_;
 621 }
 622
 623 =item C<var_uses($var)>
 624
 625 Find locations where C<$var> is used.
 626
 627 =cut
 628
 629 sub var_uses {
 630     my $v = shift;
 631     $v =~ s/.*:://;
 632     return _ret_list $var_use{$v}, @_;
 633 }
 634
 635 =item C<var_assigns($var)>
 636
 637 Find locations where C<$var> is assigned to.
 638
 639 =cut
 640
 641 sub var_assigns {
 642     my ($v, $pack) = @_;
 643     if ($v =~ /^(.*)::(.+)$/) {
 644         $v = $2;
 645         $pack = $1;
 646     }
 647     return _ret_list [ grep $_->{assign},
 648                        $pack ? @{$var_use{$v}{$pack}}
 649                        : map @$_, values %{$var_use{$v}} ], $pack;
 650 }
 651
 652 =item C<mod_files($mod)>
 653
 654 Find file for module C<$mod>.
 655
 656 =cut
 657
 658 sub mod_files {
 659 #     my $m = shift;
 660 #     return sort keys %{$module_files{$m}}
 661 #       if exists $module_files{$m};
 662 #     return undef;
 663 }
 664
 665 =item C<file_modules($file)>
 666
 667 List the modules defined in file C<$file>.
 668
 669 =cut
 670
 671 sub file_modules {
 672 #     my $f = shift;
 673 #     return sort keys %{$file_modules{$f}}
 674 #       if exists $file_modules{$f};
 675 #     return undef;
 676 }
 677
 678 sub _apropos {
 679     my ($h, $re, $mod) = @_;
 680     my @r = do {
 681         if($re) {
 682             $re = _apropos_re($re);
 683             sort grep /$re/, keys %$h;
 684         } else {
 685             sort keys %$h;
 686         }
 687     };
 688     if ($mod) {
 689         $mod = _apropos_re($mod);
 690         my %r;
 691         for (@r) {
 692             my $sn = $_;
 693             for (keys %{$h->{$_}}) {
 694                 $r{"$_\::$sn"} = 1 if /$mod/;
 695             }
 696         }
 697         @r = sort keys %r;
 698     }
 699     return wantarray ? @r : \@r;
 700 }
 701
 702 =item C<var_apropos($expr)>
 703
 704 Find variables matching C<$expr>.
 705
 706 =cut
 707
 708 sub var_apropos {
 709     _apropos \%var_use, @_;
 710 }
 711
 712 1;
 713
 714 __END__
 715
 716 =back
 717
 718 =head1 EXPORTS
 719
 720 Nothing by default, but all sub and variable described above can be
 721 imported.  C<Sepia::Xref> also defines the tags C<:most> for the
 722 above-listed functions, and C<:all> for those and the variables as
 723 well.
 724
 725 =head1 BUGS
 726
 727 See L<B::Xref>.  Also, we currently ignore module names when looking
 728 up a sub by name.  Finally, there is some evil in the way we guess
 729 file and line numbers, both of which should be done more cleanly and
 730 effectively.
 731
 732 =head1 SEE ALSO
 733
 734 L<B::Xref>, from which C<Sepia::Xref> is heavily derivative.
 735
 736 =head1 AUTHOR
 737
 738 L<B::Xref> by Malcolm Beattie, m(angl|odifi)ed by Sean O'Rourke
 739 (seano@cpan.org).
 740
 741 =cut