Xref.pm

   1 package Devel::Xref;
   2
   3 our $VERSION = '0.55';
   4
   5 =head1 NAME
   6
   7 Devel::Xref - Generates cross reference database for use by Perl programs.
   8
   9 =head1 SYNOPSIS
  10
  11     use Devel::Xref qw(rebuild defs callers);
  12
  13     rebuild;
  14     for (defs 'foo') {
  15         printf "%s:%d: sub %s\::foo() defined\n", @{$_}[0..2];
  16     }
  17
  18     for (callers 'foo') {
  19         printf "%s:%d: sub foo() called by %s\::%s().\n", @{$_}[0..3];
  20     }
  21
  22 =head1 DESCRIPTION
  23
  24 C<Devel::Xref> is intended as a programmatic interface to the
  25 information supplied by L<B::Xref>.  It is intended to be a component
  26 for interactive Perl development, with other packages providing a
  27 friendly interface to the raw information it extracts.  C<B::Xref>
  28 could be seen as an example of this sort of user-level tool, if it
  29 weren't for the fact that this module was created later, and stole
  30 most of its code.
  31
  32 =cut
  33
  34 use strict;
  35 use warnings;
  36 no warnings 'uninitialized';
  37 use Config;
  38 use Cwd 'abs_path';
  39 use B qw(peekop class comppadlist main_start svref_2object walksymtable
  40          OPpLVAL_INTRO SVf_POK OPpOUR_INTRO OPf_MOD OPpDEREF_HV OPpDEREF_AV
  41          cstring);
  42
  43 =head2 Variables
  44
  45 =over
  46
  47 =item C<%call>
  48
  49 A map of subs to call locations and callers
  50
  51 =item C<%callby>
  52
  53 A map of subs to subs called.
  54
  55 =item C<%def>
  56
  57 A map of subs to definitions.
  58
  59 =item C<%module_subs>
  60
  61 A map of packages to subs defined.
  62
  63 =item C<%var_use>
  64
  65 A map of global/package variables to uses.
  66
  67 =item C<%var_def>
  68
  69 A map of global/package variables to definitions (usually empty, since
  70 it only picks up local (...) declarations.
  71
  72 =item C<%module_files>
  73
  74 A map of module names to containing files.
  75
  76 =item C<%file_modules>
  77
  78 A map of files to module names.
  79
  80 =back
  81
  82 =cut
  83
  84 our %call;
  85 our %callby;
  86 our %def;
  87 our %module_subs;
  88 our %var_def;
  89 our %var_use;
  90 our %module_files;
  91 our %file_modules;
  92
  93 require Exporter;
  94 our @ISA = qw(Exporter);
  95 my @most = qw(redefined forget rebuild callers callees defs
  96               var_defs var_uses
  97               mod_subs mod_files mod_decls mod_apropos
  98               apropos var_apropos file_apropos);
  99 our @EXPORT_OK = (@most,
 100     qw(xref_definitions xref_object xref_main
 101        %call %callby %def %module_subs
 102        %var_use %var_def %module_files %file_modules));
 103
 104 our %EXPORT_TAGS =
 105     (all => \@EXPORT_OK,
 106      most => \@most);
 107
 108 ######################################################################
 109 ## Xref state variables:
 110
 111 sub UNKNOWN { ["?", "?", "?"] }
 112
 113 my @pad;                        # lexicals in current pad
 114                                 # as ["(lexical)", type, name]
 115 my @padval;
 116 our %done;                      # keyed by $$op: set when each $op is done
 117 my $top = UNKNOWN;              # shadows top element of stack as
 118                                 # [pack, type, name] (pack can be "(lexical)")
 119 our $file;                      # shadows current filename
 120 my $line;                       # shadows current line number
 121 our $subname;                   # shadows current sub name
 122 our @todo = ();                 # List of CVs that need processing
 123
 124 our $DEBUG = 0;
 125 sub dprint {
 126     my $type = shift;
 127     my $res = "@_";
 128     $res =~ s/%//g;
 129     print STDERR "@_" if $DEBUG =~ /$type/;
 130 }
 131
 132 my %code = (intro => "i", used => "",
 133             subdef => "s", subused => "&",
 134             formdef => "f", meth => "->");
 135
 136
 137 =item C<guess_module_file($pack, $ofile)>
 138
 139 XXX: it turns out that rooting around trying to figure out the file
 140 ourselves is more reliable than what we grab from the op.  Are we
 141 doing this wrong?
 142
 143 =cut
 144
 145 sub guess_module_file {
 146     my ($pack, $ofile) = @_;
 147     my $file;
 148
 149     # XXX: is this why we get the bogus defs?
 150     return undef if $ofile =~ /Exporter\.pm$/;
 151     # Try for standard translation in %INC:
 152     (my $fn = $pack) =~ s/::/\//g;
 153     if (exists $INC{"$fn.pm"}) {
 154         return $INC{"$fn.pm"};
 155     }
 156
 157     # Try what they told us:
 158     chomp $ofile;
 159     return $ofile if -f $ofile;
 160
 161     # Try our earlier guess of a module file:
 162     if (exists $module_files{$pack}
 163         && scalar(keys %{$module_files{$pack}}) == 1) {
 164         my ($m) = grep /\Q$ofile\E/, keys %{$module_files{$pack}};
 165         return $m if $m;
 166     }
 167
 168     # Try "parent" packages:
 169     while ($fn =~ s|/?[^/]+$|| && !$file) {
 170         $file ||= $INC{"$fn.pm"};
 171     }
 172
 173     if ($file && $file !~ /^\//) {
 174         $file = abs_path($file);
 175     }
 176
 177     if (!$file || !-f $file) {
 178         undef $file;
 179     }
 180     $file;
 181 }
 182
 183 # XXX: should weed through the code below so it only generates decent
 184 # package names, but this will fix it for now.
 185 sub realpack {
 186     my $p = shift;
 187     if (!defined $p || $p eq '?' || $p eq '(method)') {
 188         return undef;
 189     } elsif ($p eq '') {
 190         return 'main';
 191     } else {
 192         return $p;
 193     }
 194 }
 195
 196 # Turn a possibly-qualified name into a package and basename.
 197 sub split_name {
 198     local $_ = shift;
 199     my ($p, $s);
 200     if (/^(.*)::(.+)$/) {
 201         ($p, $s) = ($1, $2);
 202     } else {
 203         ($p, $s) = ('main', $_);
 204     }
 205     undef $s if $s eq '?';
 206     ($p, $s);
 207 }
 208
 209 sub process {
 210     my ($var, $event) = @_;
 211     my ($pack, $type, $name) = @$var;
 212     $pack = realpack($pack);
 213     dprint 'loud', "Processing $event: @$var ($subname)";
 214     if ($type eq "*") {
 215         if ($event eq "used" || $event eq 'set') {
 216             return;
 217         } elsif ($event eq "subused") {
 218             $type = "&";
 219         } elsif ($event eq "meth") {
 220             $type = '->';
 221         }
 222     }
 223     $type =~ s/(.)\*$/$1/g;
 224     $file = guess_module_file($pack, $file);
 225     if (defined($file)) {
 226         if ($pack) {
 227             $module_files{$pack}{$file}++;
 228             $file_modules{$file}{$pack}++;
 229         }
 230     }
 231
 232     if (($type eq '&' || $type eq '->') && $subname ne '(definitions)') {
 233         # Handle caller/callee relations
 234         my ($spack, $sname) = split_name($subname);
 235         # XXX: this is gross, but otherwise Expoerter seems to fool us.
 236         if ($file && !exists $def{$sname} || !exists $def{$sname}{$spack}) {
 237             $def{$sname}{$spack} = { file => $file, line => undef };
 238         }
 239
 240         push @{$call{$name}{$pack}},
 241         { # file => $file,      # This is actually $sname's file...
 242           sub => $sname,
 243           package => $spack,
 244           line => $line
 245         };
 246
 247         push @{$callby{$sname}{$spack}}, { sub => $name, package => $pack };
 248     } elsif ($type eq 's' || $subname eq '(definitions)') {
 249         # Handle definition
 250         if ($file) {
 251             my $obj = { file => $file, line => $line };
 252             $module_subs{$pack}{$name} = $obj;
 253             $def{$name}{$pack} = $obj;
 254             dprint 'def', "$pack\::$name defined at $line\n";
 255         }
 256     } elsif ($name !~ /^[\x00-\x1f^] | ^\d+$ | ^[\W_]$
 257                        | ^(?:ENV|INC|STD(?:IN|OUT|ERR)|SIG)$ /x
 258              && realpack($pack)) {
 259         # Variables, but ignore specials and lexicals
 260         my ($spack, $sname) = split_name($subname);
 261         if ($event eq 'intro') {
 262             $var_def{$name}{$pack} =
 263             { file => $file,
 264               package => $spack,
 265               line => $line,
 266               sub => $sname,
 267             };
 268         } elsif ($event eq 'used' || $event eq 'set') {
 269             push @{$var_use{$name}{$pack}},
 270             { file => $file,
 271               package => $spack,
 272               line => $line,
 273               sub => $sname,
 274               assign => ($event eq 'set'),
 275             };
 276         } else {
 277             dprint 'ignore', "Ignoring var event $event";
 278         }
 279     } else {
 280         dprint 'ignore', "Ignoring $type event $event";
 281     }
 282 }
 283
 284 # Because the CV's line number points to the end of the sub, we guess
 285 # a line number based on the first pp_nextstate seen in the sub.
 286 # XXX: unused for now -- fix these up later.
 287 sub update_line_number {
 288     my ($pack, $name) = split_name($subname);
 289     my $found;
 290     my $l = $line - 1; # because we usually see "sub foo {\n    first_stmt...}"
 291     if ($pack && exists $def{$name} && exists $def{$name}{$pack}
 292         && $l < $def{$name}{$pack}{line}) {
 293         $def{$name}{$pack}{line} = $l;
 294     }
 295 }
 296
 297 sub load_pad {
 298     my $padlist = shift;
 299     my ($namelistav, $vallistav, @namelist, $ix);
 300     @pad = ();
 301     @padval = ();
 302     return if class($padlist) eq "SPECIAL";
 303     ($namelistav,$vallistav) = $padlist->ARRAY;
 304     @namelist = $namelistav->ARRAY;
 305     for ($ix = 1; $ix < @namelist; $ix++) {
 306         my $namesv = $namelist[$ix];
 307         next if class($namesv) eq "SPECIAL";
 308         my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
 309         $pad[$ix] = [undef, $type, $name];
 310     }
 311     if ($Config{useithreads}) {
 312         my (@vallist);
 313         @vallist = $vallistav->ARRAY;
 314         for ($ix = 1; $ix < @vallist; $ix++) {
 315             my $valsv = $vallist[$ix];
 316             next unless class($valsv) eq "GV";
 317             # these pad GVs don't have corresponding names, so same @pad
 318             # array can be used without collisions
 319             $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
 320         }
 321     }
 322     @padval = $vallistav->ARRAY;
 323 }
 324
 325 sub xref {
 326     my $start = shift;
 327     my $op;
 328     for ($op = $start; $$op; $op = $op->next) {
 329         last if $done{$$op}++;
 330         my $opname = $op->name;
 331         if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
 332             xref($op->other);
 333         } elsif ($opname eq "match" || $opname eq "subst") {
 334             xref($op->pmreplstart);
 335         } elsif ($opname eq "substcont") {
 336             xref($op->other->pmreplstart);
 337             $op = $op->other;
 338             redo;
 339         } elsif ($opname eq "enterloop") {
 340             xref($op->redoop);
 341             xref($op->nextop);
 342             xref($op->lastop);
 343         } elsif ($opname eq "subst") {
 344             xref($op->pmreplstart);
 345         } else {
 346             no strict 'refs';
 347             my $ppname = "pp_$opname";
 348             &$ppname($op) if defined(&$ppname);
 349         }
 350     }
 351 }
 352
 353 sub xref_cv {
 354     my $cv = shift;
 355     my $pack = $cv->GV->STASH->NAME;
 356     local $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
 357     load_pad($cv->PADLIST);
 358     xref($cv->START);
 359 }
 360
 361 sub xref_object {
 362     my $cvref = shift;
 363     local (@todo, %done);
 364     my $cv = svref_2object($cvref);
 365     xref_cv($cv);
 366     dprint 'todo', "todo = (@todo)";
 367     my $gv = $cv->GV;
 368     process([$gv->STASH->NAME, '&', $gv->NAME], 'subdef');
 369 }
 370
 371 sub xref_main {
 372     $subname = "(main)";
 373     load_pad(comppadlist);
 374     xref(main_start);
 375     while (@todo) {
 376         xref_cv(shift @todo);
 377     }
 378 }
 379
 380 sub pp_nextstate {
 381     my $op = shift;
 382     $file = $op->file;
 383     die "pp_nextstate: $file" if $file =~ /::/;
 384     $line = $op->line;
 385 #    update_line_number;
 386     $top = UNKNOWN;
 387 }
 388
 389 sub use_type($) {
 390     my ($op) = @_;
 391     if ($op->private & (OPpLVAL_INTRO | OPpOUR_INTRO)) {
 392         'intro';
 393     } elsif ($op->flags & OPf_MOD
 394              && !($op->private & (OPpDEREF_HV | OPpDEREF_AV))) {
 395         'set';
 396     } else {
 397         'used';
 398     }
 399 }
 400
 401 sub pp_padsv {
 402     my $op = shift;
 403      $top = $pad[$op->targ];
 404 #     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 405 }
 406
 407 sub pp_padav { pp_padsv(@_) }
 408 sub pp_padhv { pp_padsv(@_) }
 409
 410 sub deref {
 411     my ($op, $var, $as) = @_;
 412     $var->[1] = $as . $var->[1];
 413     process($var, use_type $op);
 414 }
 415
 416 sub pp_rv2cv { deref(shift, $top, "&"); }
 417 sub pp_rv2hv { deref(shift, $top, "%"); }
 418 sub pp_rv2sv { deref(shift, $top, "\$"); }
 419 sub pp_rv2av { deref(shift, $top, "\@"); }
 420 sub pp_rv2gv { deref(shift, $top, "*"); }
 421
 422 sub pp_gvsv {
 423     my $op = shift;
 424     my $gv;
 425     if ($Config{useithreads}) {
 426         $top = $pad[$op->padix];
 427         $top = UNKNOWN unless $top;
 428         $top->[1] = '$';
 429     }
 430     else {
 431         $gv = $op->gv;
 432         $top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
 433     }
 434     process($top, use_type $op);
 435 }
 436
 437 sub pp_gv {
 438     my $op = shift;
 439     my $gv;
 440     if ($Config{useithreads}) {
 441         $top = $pad[$op->padix];
 442         $top = UNKNOWN unless $top;
 443         $top->[1] = '*';
 444     }
 445     else {
 446         $gv = $op->gv;
 447         $top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
 448     }
 449     process($top, use_type $op);
 450 }
 451
 452 my $lastclass;
 453
 454 sub pp_const {
 455     my $op = shift;
 456     my $sv = $op->sv;
 457     # constant could be in the pad (under useithreads)
 458     if ($$sv) {
 459         $top = [undef, "",
 460                 (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
 461                 ? $sv->PV : undef];
 462     }
 463     else {
 464         $top = $pad[$op->targ];
 465         my $pv = $padval[$op->targ];
 466         if (class($pv) eq 'PV') {
 467             $pv = $pv->PV;
 468             $lastclass = $pv if class($sv) eq 'SPECIAL'
 469                 && ($op->private & 64); # bareword
 470         } else {
 471             $pv = "XXX: ".class($pv);
 472         }
 473         dprint 'method', "blah constant ".$op->targ." pad = `$top'/`$pv'";
 474         $top = UNKNOWN unless $top;
 475     }
 476 }
 477
 478 sub pp_method {
 479     my $op = shift;
 480     $top = [$lastclass || "(method)", "->".$top->[1], $top->[2]];
 481     dprint 'method', "pp_method($top->[1])";
 482     undef $lastclass;
 483 }
 484
 485 sub pp_method_named {
 486     use Data::Dumper;
 487     my $op = shift;
 488     my $sv = $op->sv;
 489     my $pviv = $padval[$op->targ];
 490     if ($pviv && class($pviv) =~ /^PV/) {
 491         my $name = $pviv->PV;
 492         dprint 'method_named', $op->targ.": $name";
 493         undef $top->[2] if $top->[2] eq '?';
 494         $top = [$top->[2] || $lastclass || "(method)", '->', $name];
 495         undef $lastclass;
 496     } else {
 497         warn "method_named: wtf: sizeof padval = ".@padval;
 498     }
 499 }
 500
 501 sub pp_entersub {
 502     my $op = shift;
 503     if ($top->[1] =~ /^(?:m$|->)/) {
 504         dprint 'method', "call to (@$top) from $subname";
 505         process($top, "meth");
 506     } else {
 507         process($top, "subused");
 508     }
 509     undef $lastclass;
 510     $top = UNKNOWN;
 511 }
 512
 513 #
 514 # Stuff for cross referencing definitions of variables and subs
 515 #
 516
 517 sub B::GV::xref {
 518     my $gv = shift;
 519     my $cv = $gv->CV;
 520     $file = $gv->FILE;
 521     # XXX: sometimes the "file" is a module.  Why?
 522     $line = $gv->LINE;
 523     if ($$cv) {
 524         #return if $done{$$cv}++;
 525         process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 526         push(@todo, $cv);
 527     }
 528     my $form = $gv->FORM;
 529     if ($$form) {
 530         return if $done{$$form}++;
 531         process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
 532     }
 533 }
 534
 535 sub xref_definitions {
 536     my ($pack, %exclude);
 537     $subname = "(definitions)";
 538     foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 539                       strict vars FileHandle Exporter Carp PerlIO::Layer
 540                       attributes utf8 warnings)) {
 541         $exclude{$pack."::"} = 1;
 542     }
 543     no strict qw(vars refs);
 544     walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
 545 }
 546
 547 =head2 Functions
 548
 549 =over
 550
 551 =item C<rebuild()>
 552
 553 Rebuild the Xref database.
 554
 555 =cut
 556
 557 sub rebuild {
 558     %call = (); %callby = (); %def = (); %module_subs = ();
 559     %var_def = (); %var_use = ();
 560     %module_files = (); %file_modules = ();
 561     local (@todo, %done);
 562     xref_definitions;
 563     xref_main;
 564     1;
 565 }
 566
 567 sub unmention {
 568     my ($h, $K, $V, $pack) = @_;
 569     dprint 'unmention', "Unmentioning $K => $V";
 570     while (my ($k, $v) = each %$h) {
 571         while (my ($k2, $v2) = each %$v) {
 572             if (ref $v2 eq 'ARRAY') {
 573                 $v->{$k2} = [grep {
 574                     $_->{$K} ne $V || !$pack || $pack ne $_->{package}
 575                 } @$v2];
 576                 delete $v->{$k2} unless @{$v->{$k2}};
 577             } else {
 578                 delete $v->{$k2} if $k2 eq $V;
 579             }
 580         }
 581         delete $h->{$k} unless keys %{$h->{$k}};
 582     }
 583 }
 584
 585 sub unmention_sub {
 586     my ($h, $sub, $pack) = @_;
 587     dprint 'unmention', "Unmentioning $pack\::$sub";
 588     if ($pack) {
 589         delete $h->{$sub}{$pack};
 590         delete $h->{$sub} unless keys %{$h->{$sub}};
 591     } else {
 592         delete $h->{$sub};
 593     }
 594 }
 595
 596 =item C<forget($func [, $mod])>
 597
 598 Forget that C<$func> was defined.
 599
 600 =cut
 601
 602 sub forget {
 603     my ($obj, $pack) = @_;
 604     unmention_sub \%def, @_;
 605     unmention_sub \%callby, @_;
 606     unmention \%call, 'sub', @_;
 607     delete $module_subs{$pack}{$obj};
 608     delete $module_subs{$pack} unless keys %{$module_subs{$pack}};
 609     unmention \%var_use, 'sub', @_;
 610     unmention \%var_def, 'sub', @_;
 611 }
 612
 613 =item C<redefined($func [, $pack])>
 614
 615 Recompute xref info for C<$func>, or C<$pack::$func> if C<$pack> given.
 616
 617 =cut
 618
 619 sub redefined {
 620     forget @_;
 621     {
 622         no strict 'refs';
 623         my ($sub, $pack) = @_;
 624         $pack ||= 'main';
 625         $sub = $pack eq 'main' ? $sub : "$pack\::$sub";
 626         local $subname = '(definitions)';
 627         xref_object \&$sub;
 628     }
 629 }
 630
 631 =item C<mod_redefined($m)>
 632
 633 Recompute Xref information for module C<$m>.
 634
 635 =cut
 636
 637 sub mod_redefined {
 638     my $mod = shift;
 639     redefined $_, $mod for keys %{$module_subs{$mod}};
 640 }
 641
 642 ######################################################################
 643 # Apropos and definition-finding:
 644
 645 sub _ret_list {
 646     my ($l, $mod, $sub) = @_;
 647     my @mod;
 648     if ($mod) {
 649         @mod = ($mod);
 650     } else {
 651         @mod = keys %$l;
 652     }
 653     my @r = map {
 654         my $lm = $l->{$_};
 655         $mod = $_;
 656         map {
 657             [$_->{file} || undef, $_->{line}, $_->{sub} || $sub,
 658              $_->{package} || $mod ]
 659         } (ref($lm) eq 'ARRAY' ? @$lm : $lm);
 660     } @mod;
 661     @r = grep { $_->[0] !~ /Exporter\.pm$/ } @r
 662         unless $mod && $mod eq 'Exporter';
 663     return wantarray ? @r : \@r;
 664 }
 665
 666 =item C<callers($func)>
 667
 668 List callers of C<$func>.
 669
 670 =cut
 671
 672 sub callers {
 673     my $f = shift;
 674     return _ret_list $call{$f}, @_;
 675 }
 676
 677 =item C<defs($func)>
 678
 679 Find locations where C<$func> is defined.
 680
 681 =cut
 682
 683 sub defs {
 684     my ($f, $pack) = @_;
 685     $f =~ s/.*:://;
 686     return _ret_list $def{$f}, $pack, $f;
 687 }
 688
 689 =item C<callees($func)>
 690
 691 List callees of C<$func>.
 692
 693 =cut
 694
 695 sub callees {
 696     my ($f, $pack) = @_;
 697     my @r = map {
 698         defs($_->{sub});
 699     } ($pack ? @{$callby{$f}{$pack}} : map @$_, values %{$callby{$f}});
 700     return wantarray ? @r : \@r;
 701 }
 702
 703 =item C<var_defs($var)>
 704
 705 Find locations where C<$var> is defined.
 706
 707 =cut
 708
 709 sub var_defs {
 710     my $v = shift;
 711     $v =~ s/.*:://;
 712     return _ret_list $var_def{$v}, @_;
 713 }
 714
 715 =item C<var_uses($var)>
 716
 717 Find locations where C<$var> is used.
 718
 719 =cut
 720
 721 sub var_uses {
 722     my $v = shift;
 723     $v =~ s/.*:://;
 724     return _ret_list $var_use{$v}, @_;
 725 }
 726
 727 =item C<var_assigns($var)>
 728
 729 Find locations where C<$var> is assigned to.
 730
 731 =cut
 732
 733 sub var_assigns {
 734     my ($v, $pack) = @_;
 735     if ($v =~ /^(.*)::(.+)$/) {
 736         $v = $2;
 737         $pack = $1;
 738     }
 739     return _ret_list [ grep $_->{assign},
 740                        $pack ? @{$var_use{$v}{$pack}}
 741                        : map @$_, values %{$var_use{$v}} ], $pack;
 742 }
 743
 744 =item C<mod_subs($pack)>
 745
 746 Find subs in package C<$pack>.
 747
 748 =cut
 749
 750 sub mod_subs {
 751     my $p = shift;
 752     return _ret_list $module_subs{$p};
 753 }
 754
 755 =item C<mod_decls($pack)>
 756
 757 Generate a list of declarations for all subroutines in package
 758 C<$pack>.
 759
 760 =cut
 761
 762 sub mod_decls {
 763     my $pack = shift;
 764     no strict 'refs';
 765     my @ret = map {
 766         my $sn = $_->[3];
 767         my $proto = prototype(\&{"$pack\::$sn"});
 768         $proto = defined($proto) ? "($proto)" : '';
 769         "sub $sn $proto;\n";
 770     } Devel::Xref::mod_subs($pack);
 771     return wantarray ? @ret : join '', @ret;
 772 }
 773
 774 =item C<mod_files($mod)>
 775
 776 Find file for module C<$mod>.
 777
 778 =cut
 779
 780 sub mod_files {
 781     my $m = shift;
 782     return sort keys %{$module_files{$m}}
 783         if exists $module_files{$m};
 784     return undef;
 785 }
 786
 787 =item C<file_modules($file)>
 788
 789 List the modules defined in file C<$file>.
 790
 791 =cut
 792
 793 sub file_modules {
 794     my $f = shift;
 795     return sort keys %{$file_modules{$f}}
 796         if exists $file_modules{$f};
 797     return undef;
 798 }
 799
 800 =item C<apropos($expr)>
 801
 802 Find subs matching C<$expr>.
 803
 804 =cut
 805
 806 sub _apropos_re($) {
 807     # Do that crazy multi-word identifier completion thing:
 808     my $re = shift;
 809     if ($re !~ /[^\w\d_^:]/) {
 810         $re =~ s/(?<=[A-Za-z\d])([^A-Za-z\d])/[A-Za-z\\d]*$1+/g;
 811     }
 812     qr/$re/;
 813 }
 814
 815 sub _apropos {
 816     my ($h, $re, $mod) = @_;
 817     my @r = do {
 818         if($re) {
 819             $re = _apropos_re($re);
 820             sort grep /$re/, keys %$h;
 821         } else {
 822             sort keys %$h;
 823         }
 824     };
 825     if ($mod) {
 826         $mod = _apropos_re($mod);
 827         my %r;
 828         for (@r) {
 829             my $sn = $_;
 830             for (keys %{$h->{$_}}) {
 831                 $r{"$_\::$sn"} = 1 if /$mod/;
 832             }
 833         }
 834         @r = sort keys %r;
 835     }
 836     return wantarray ? @r : \@r;
 837 }
 838
 839 sub apropos {
 840     _apropos \%def, @_;
 841 }
 842
 843 =item C<var_apropos($expr)>
 844
 845 Find variables matching C<$expr>.
 846
 847 =cut
 848
 849 sub var_apropos {
 850     _apropos \%var_use, @_;
 851 }
 852
 853 =item C<mod_apropos($expr)>
 854
 855 Find modules matching C<$expr>.
 856
 857 =cut
 858
 859 sub mod_apropos {
 860     _apropos \%module_files, @_;
 861 }
 862
 863 =item C<file_apropos($expr)>
 864
 865 Find modules matching C<$expr>.
 866
 867 =cut
 868
 869 sub file_apropos {
 870     _apropos \%file_modules, @_;
 871 }
 872
 873 =item C<completions($string)>
 874
 875 =cut
 876
 877 sub completions {
 878     no strict;
 879     my ($str) = @_;
 880     if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 881         my @nameparts = split /:+/, $name;
 882         local *_completions = sub {
 883             no strict;
 884             my ($stash, $part, @rest) = @_;
 885             $part = join '[^_]*_', split /_/, $part;
 886             if (@rest) {
 887                 map {
 888                     _completions("$stash$_", @rest)
 889                 } grep /^$part.*\::$/, keys %$stash;
 890             } else {
 891                 map { "$stash$_" } grep /^$part/, keys %$stash;
 892             }
 893         };
 894
 895         my $type = ($pfx eq '$' ? 'SCALAR'
 896                     : $pfx eq '@' ? 'ARRAY'
 897                     : $pfx eq '&' ? 'CODE'
 898                     : $pfx eq '%' ? 'HASH'
 899                     : undef);
 900         map {
 901             s/^::/$pfx/;$_
 902         } grep {
 903             !$type || defined(*{$_}{$type})
 904         } _completions('::', @nameparts);
 905     }
 906 }
 907
 908 =item C<location($name)>
 909
 910 =cut
 911
 912 sub location {
 913     no strict;
 914     my ($str) = @_;
 915     if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 916         if ($pfx) {
 917             print STDERR "Sorry -- can't lookup variables.";
 918             ();
 919         } else {
 920             my $cv = B::svref_2object(\&{$name});
 921             if ($cv && ($cv = $cv->START) && !$cv->isa('B::NULL')) {
 922                 my ($file, $line) = ($cv->file, $cv->line);
 923                 if ($file !~ /^\//) {
 924                     for (@INC) {
 925                         if (-f "$_/$file") {
 926                             $file = "$_/$file";
 927                             last;
 928                         }
 929                     }
 930                 }
 931                 my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
 932                 (Cwd::abs_path($file), $line, $shortname)
 933             } else {
 934                 ();
 935             }
 936         }
 937     }
 938 }
 939
 940 =item C<find_item($name)>
 941
 942 =cut
 943
 944 sub my_walksymtable(&*) {
 945     no strict;
 946     my ($f, $st) = @_;
 947     local *_walk = sub {
 948         local ($stash) = @_;
 949         &$f for keys %$stash;
 950         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 951     };
 952     _walk($st);
 953 }
 954
 955 sub find_item {
 956     no strict;
 957     my ($it, $re) = @_;
 958     my @ret;
 959     my $findre = $re ? qr/^\Q$it\E$/ : qr/$re/;
 960     my_walksymtable {
 961         push @ret, "$stash$_" if /$findre/;
 962     } '::';
 963     map { s/^:://;$_ } @ret;
 964 }
 965
 966 1;
 967
 968 __END__
 969
 970 =back
 971
 972 =head1 EXPORTS
 973
 974 Nothing by default, but all sub and variable described above can be
 975 imported.  C<Devel::Xref> also defines the tags C<:most> for the
 976 above-listed functions, and C<:all> for those and the variables as
 977 well.
 978
 979 =head1 BUGS
 980
 981 See L<B::Xref>.  Also, we currently ignore module names when looking
 982 up a sub by name.  Finally, there is some evil in the way we guess
 983 file and line numbers, both of which should be done more cleanly and
 984 effectively.
 985
 986 =head1 SEE ALSO
 987
 988 L<B::Xref>, from which C<Devel::Xref> is heavily derivative.
 989
 990 =head1 AUTHOR
 991
 992 L<B::Xref> by Malcolm Beattie, m(angl|odifi)ed by Sean O'Rourke
 993 (seano@cpan.org).
 994
 995 =cut