scripts/perldeps.pl

   1 #!/usr/bin/perl -Tw
   2 #
   3 # perldeps.pl -- Analyze dependencies of Perl packages
   4 #
   5 # Michael Jennings
   6 # 7 November 2005
   7 #
   8 # $Id: perldeps.pl,v 1.6 2006/04/04 20:12:03 mej Exp $
   9 #
  10
  11 use strict;
  12 use Config;
  13 use File::Basename;
  14 use File::Find;
  15 use Getopt::Long;
  16 use POSIX;
  17
  18 ############### Debugging stolen from Mezzanine::Util ###############
  19 my $DEBUG = 0;
  20
  21 # Debugging output
  22 sub
  23 dprintf(@)
  24 {
  25     my ($f, $l, $s, $format);
  26     my @params = @_;
  27
  28     return if (! $DEBUG);
  29     $format = shift @params;
  30     if (!scalar(@params)) {
  31         return dprint($format);
  32     }
  33     (undef, undef, undef, $s) = caller(1);
  34     if (!defined($s)) {
  35         $s = "MAIN";
  36     }
  37     (undef, $f, $l) = caller(0);
  38     $f =~ s/^.*\/([^\/]+)$/$1/;
  39     $s =~ s/^\w+:://g;
  40     $s .= "()" if ($s =~ /^\w+$/);
  41     $f = "" if (!defined($f));
  42     $l = "" if (!defined($l));
  43     $format = "" if (!defined($format));
  44     for (my $i = 0; $i < scalar(@params); $i++) {
  45         if (!defined($params[$i])) {
  46             $params[$i] = "<undef>";
  47         }
  48     }
  49     printf("[$f/$l/$s] $format", @params);
  50 }
  51
  52 sub
  53 dprint(@)
  54 {
  55     my ($f, $l, $s);
  56     my @params = @_;
  57
  58     return if (! $DEBUG);
  59     (undef, undef, undef, $s) = caller(1);
  60     if (!defined($s)) {
  61         $s = "MAIN";
  62     }
  63     (undef, $f, $l) = caller(0);
  64     $f =~ s/^.*\/([^\/]+)$/$1/;
  65     $s =~ s/\w+:://g;
  66     $s .= "()" if ($s =~ /^\w+$/);
  67     $f = "" if (!defined($f));
  68     $l = "" if (!defined($l));
  69     $s = "" if (!defined($s));
  70     for (my $i = 0; $i < scalar(@params); $i++) {
  71         if (!defined($params[$i])) {
  72             $params[$i] = "<undef>";
  73         }
  74     }
  75     print "[$f/$l/$s] ", @params;
  76 }
  77
  78 ############### Module::ScanDeps Code ###############
  79 use constant dl_ext  => ".$Config{dlext}";
  80 use constant lib_ext => $Config{lib_ext};
  81 use constant is_insensitive_fs => (
  82     -s $0
  83         and (-s lc($0) || -1) == (-s uc($0) || -1)
  84         and (-s lc($0) || -1) == -s $0
  85 );
  86
  87 my $CurrentPackage = '';
  88 my $SeenTk;
  89
  90 # Pre-loaded module dependencies
  91 my %Preload = (
  92     'AnyDBM_File.pm'  => [qw( SDBM_File.pm )],
  93     'Authen/SASL.pm'  => 'sub',
  94     'Bio/AlignIO.pm'  => 'sub',
  95     'Bio/Assembly/IO.pm'  => 'sub',
  96     'Bio/Biblio/IO.pm'  => 'sub',
  97     'Bio/ClusterIO.pm'  => 'sub',
  98     'Bio/CodonUsage/IO.pm'  => 'sub',
  99     'Bio/DB/Biblio.pm'  => 'sub',
 100     'Bio/DB/Flat.pm'  => 'sub',
 101     'Bio/DB/GFF.pm'  => 'sub',
 102     'Bio/DB/Taxonomy.pm'  => 'sub',
 103     'Bio/Graphics/Glyph.pm'  => 'sub',
 104     'Bio/MapIO.pm'  => 'sub',
 105     'Bio/Matrix/IO.pm'  => 'sub',
 106     'Bio/Matrix/PSM/IO.pm'  => 'sub',
 107     'Bio/OntologyIO.pm'  => 'sub',
 108     'Bio/PopGen/IO.pm'  => 'sub',
 109     'Bio/Restriction/IO.pm'  => 'sub',
 110     'Bio/Root/IO.pm'  => 'sub',
 111     'Bio/SearchIO.pm'  => 'sub',
 112     'Bio/SeqIO.pm'  => 'sub',
 113     'Bio/Structure/IO.pm'  => 'sub',
 114     'Bio/TreeIO.pm'  => 'sub',
 115     'Bio/LiveSeq/IO.pm'  => 'sub',
 116     'Bio/Variation/IO.pm'  => 'sub',
 117     'Crypt/Random.pm' => sub {
 118         _glob_in_inc('Crypt/Random/Provider', 1);
 119     },
 120     'Crypt/Random/Generator.pm' => sub {
 121         _glob_in_inc('Crypt/Random/Provider', 1);
 122     },
 123     'DBI.pm' => sub {
 124         grep !/\bProxy\b/, _glob_in_inc('DBD', 1);
 125     },
 126     'DBIx/SearchBuilder.pm' => 'sub',
 127     'DBIx/ReportBuilder.pm' => 'sub',
 128     'Device/ParallelPort.pm' => 'sub',
 129     'Device/SerialPort.pm' => [ qw(
 130         termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
 131     ) ],
 132     'ExtUtils/MakeMaker.pm' => sub {
 133         grep /\bMM_/, _glob_in_inc('ExtUtils', 1);
 134     },
 135     'File/Basename.pm' => [qw( re.pm )],
 136     'File/Spec.pm'     => sub {
 137         require File::Spec;
 138         map { my $name = $_; $name =~ s!::!/!g; "$name.pm" } @File::Spec::ISA;
 139     },
 140     'HTTP/Message.pm' => [ qw(
 141         URI/URL.pm          URI.pm
 142     ) ],
 143     'IO.pm' => [ qw(
 144         IO/Handle.pm        IO/Seekable.pm      IO/File.pm
 145         IO/Pipe.pm          IO/Socket.pm        IO/Dir.pm
 146     ) ],
 147     'IO/Socket.pm'     => [qw( IO/Socket/UNIX.pm )],
 148     'LWP/UserAgent.pm' => [ qw(
 149         URI/URL.pm          URI/http.pm         LWP/Protocol/http.pm
 150         LWP/Protocol/https.pm
 151     ), _glob_in_inc("LWP/Authen", 1) ],
 152     'Locale/Maketext/Lexicon.pm'    => 'sub',
 153     'Locale/Maketext/GutsLoader.pm' => [qw( Locale/Maketext/Guts.pm )],
 154     'Mail/Audit.pm'                => 'sub',
 155     'Math/BigInt.pm'                => 'sub',
 156     'Math/BigFloat.pm'              => 'sub',
 157     'Module/Build.pm'               => 'sub',
 158     'Module/Pluggable.pm'           => sub {
 159         _glob_in_inc("$CurrentPackage/Plugin", 1);
 160     },
 161     'MIME/Decoder.pm'               => 'sub',
 162     'Net/DNS/RR.pm'                 => 'sub',
 163     'Net/FTP.pm'                    => 'sub',
 164     'Net/SSH/Perl.pm'               => 'sub',
 165     'PDF/API2/Resource/Font.pm'     => 'sub',
 166     'PDF/API2/Basic/TTF/Font.pm'    => sub {
 167         _glob_in_inc('PDF/API2/Basic/TTF', 1);
 168     },
 169     'PDF/Writer.pm'                 => 'sub',
 170     'POE'                           => [ qw(
 171         POE/Kernel.pm POE/Session.pm
 172     ) ],
 173     'POE/Kernel.pm'                    => [
 174         map "POE/Resource/$_.pm", qw(
 175             Aliases Events Extrefs FileHandles
 176             SIDs Sessions Signals Statistics
 177         )
 178     ],
 179     'Parse/AFP.pm'                  => 'sub',
 180     'Parse/Binary.pm'               => 'sub',
 181     'Regexp/Common.pm'              => 'sub',
 182     'SOAP/Lite.pm'                  => sub {
 183         (($] >= 5.008 ? ('utf8.pm') : ()), _glob_in_inc('SOAP/Transport', 1));
 184     },
 185     'SQL/Parser.pm' => sub {
 186         _glob_in_inc('SQL/Dialects', 1);
 187     },
 188     'SVN/Core.pm' => sub {
 189         _glob_in_inc('SVN', 1),
 190         map "auto/SVN/$_->{name}", _glob_in_inc('auto/SVN'),
 191     },
 192     'SVK/Command.pm' => sub {
 193         _glob_in_inc('SVK', 1);
 194     },
 195     'SerialJunk.pm' => [ qw(
 196         termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
 197     ) ],
 198     'Template.pm'      => 'sub',
 199     'Term/ReadLine.pm' => 'sub',
 200     'Tk.pm'            => sub {
 201         $SeenTk = 1;
 202         qw( Tk/FileSelect.pm Encode/Unicode.pm );
 203     },
 204     'Tk/Balloon.pm'     => [qw( Tk/balArrow.xbm )],
 205     'Tk/BrowseEntry.pm' => [qw( Tk/cbxarrow.xbm Tk/arrowdownwin.xbm )],
 206     'Tk/ColorEditor.pm' => [qw( Tk/ColorEdit.xpm )],
 207     'Tk/FBox.pm'        => [qw( Tk/folder.xpm Tk/file.xpm )],
 208     'Tk/Toplevel.pm'    => [qw( Tk/Wm.pm )],
 209     'URI.pm'            => sub {
 210         grep !/.\b[_A-Z]/, _glob_in_inc('URI', 1);
 211     },
 212     'Win32/EventLog.pm'    => [qw( Win32/IPC.pm )],
 213     'Win32/Exe.pm'         => 'sub',
 214     'Win32/TieRegistry.pm' => [qw( Win32API/Registry.pm )],
 215     'Win32/SystemInfo.pm'  => [qw( Win32/cpuspd.dll )],
 216     'XML/Parser.pm'        => sub {
 217         _glob_in_inc('XML/Parser/Style', 1),
 218         _glob_in_inc('XML/Parser/Encodings', 1),
 219     },
 220     'XML/Parser/Expat.pm' => sub {
 221         ($] >= 5.008) ? ('utf8.pm') : ();
 222     },
 223     'XML/SAX.pm' => [qw( XML/SAX/ParserDetails.ini ) ],
 224     'XMLRPC/Lite.pm' => sub {
 225         _glob_in_inc('XMLRPC/Transport', 1),;
 226     },
 227     'diagnostics.pm' => sub {
 228         _find_in_inc('Pod/perldiag.pod')
 229           ? 'Pod/perldiag.pl'
 230           : 'pod/perldiag.pod';
 231     },
 232     'utf8.pm' => [
 233         'utf8_heavy.pl', do {
 234             my $dir = 'unicore';
 235             my @subdirs = qw( To );
 236             my @files = map "$dir/lib/$_->{name}", _glob_in_inc("$dir/lib");
 237
 238             if (@files) {
 239                 # 5.8.x
 240                 push @files, (map "$dir/$_.pl", qw( Exact Canonical ));
 241             }
 242             else {
 243                 # 5.6.x
 244                 $dir = 'unicode';
 245                 @files = map "$dir/Is/$_->{name}", _glob_in_inc("$dir/Is")
 246                   or return;
 247                 push @subdirs, 'In';
 248             }
 249
 250             foreach my $subdir (@subdirs) {
 251                 foreach (_glob_in_inc("$dir/$subdir")) {
 252                     push @files, "$dir/$subdir/$_->{name}";
 253                 }
 254             }
 255             @files;
 256         }
 257     ],
 258     'charnames.pm' => [
 259         _find_in_inc('unicore/Name.pl') ? 'unicore/Name.pl' : 'unicode/Name.pl'
 260     ],
 261 );
 262
 263 my $Keys = 'files|keys|recurse|rv|skip|first|execute|compile';
 264 sub scan_deps {
 265     my %args = (
 266         rv => {},
 267         (@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
 268     );
 269
 270     scan_deps_static(\%args);
 271
 272     if ($args{execute} or $args{compile}) {
 273         scan_deps_runtime(
 274             rv      => $args{rv},
 275             files   => $args{files},
 276             execute => $args{execute},
 277             compile => $args{compile},
 278             skip    => $args{skip}
 279         );
 280     }
 281
 282     return ($args{rv});
 283 }
 284
 285 sub scan_deps_static {
 286     my ($args) = @_;
 287     my ($files, $keys, $recurse, $rv, $skip, $first, $execute, $compile) =
 288       @$args{qw( files keys recurse rv skip first execute compile )};
 289
 290     $rv   ||= {};
 291     $skip ||= {};
 292
 293     foreach my $file (@{$files}) {
 294         my $key = shift @{$keys};
 295         next if $skip->{$file}++;
 296         next if is_insensitive_fs()
 297           and $file ne lc($file) and $skip->{lc($file)}++;
 298
 299         local *FH;
 300         open FH, $file or die "Cannot open $file: $!";
 301
 302         $SeenTk = 0;
 303
 304         # Line-by-line scanning
 305         LINE:
 306         while (<FH>) {
 307             chomp(my $line = $_);
 308             foreach my $pm (scan_line($line)) {
 309                 last LINE if $pm eq '__END__';
 310
 311                 if ($pm eq '__POD__') {
 312                     while (<FH>) { last if (/^=cut/) }
 313                     next LINE;
 314                 }
 315
 316                 $pm = 'CGI/Apache.pm' if /^Apache(?:\.pm)$/;
 317
 318                 add_deps(
 319                     used_by => $key,
 320                     rv      => $rv,
 321                     modules => [$pm],
 322                     skip    => $skip
 323                 );
 324
 325                 my $preload = $Preload{$pm} or next;
 326                 if ($preload eq 'sub') {
 327                     $pm =~ s/\.p[mh]$//i;
 328                     $preload = [ _glob_in_inc($pm, 1) ];
 329                 }
 330                 elsif (UNIVERSAL::isa($preload, 'CODE')) {
 331                     $preload = [ $preload->($pm) ];
 332                 }
 333
 334                 add_deps(
 335                     used_by => $key,
 336                     rv      => $rv,
 337                     modules => $preload,
 338                     skip    => $skip
 339                 );
 340             }
 341         }
 342         close FH;
 343
 344         # }}}
 345     }
 346
 347     # Top-level recursion handling {{{
 348     while ($recurse) {
 349         my $count = keys %$rv;
 350         my @files = sort grep -T $_->{file}, values %$rv;
 351         scan_deps_static({
 352             files   => [ map $_->{file}, @files ],
 353             keys    => [ map $_->{key},  @files ],
 354             rv      => $rv,
 355             skip    => $skip,
 356             recurse => 0,
 357         }) or ($args->{_deep} and return);
 358         last if $count == keys %$rv;
 359     }
 360
 361     # }}}
 362
 363     return $rv;
 364 }
 365
 366 sub scan_deps_runtime {
 367     my %args = (
 368         perl => $^X,
 369         rv   => {},
 370         (@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
 371     );
 372     my ($files, $rv, $execute, $compile, $skip, $perl) =
 373       @args{qw( files rv execute compile skip perl )};
 374
 375     $files = (ref($files)) ? $files : [$files];
 376
 377     my ($inchash, $incarray, $dl_shared_objects) = ({}, [], []);
 378     if ($compile) {
 379         my $file;
 380
 381         foreach $file (@$files) {
 382             ($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
 383             _compile($perl, $file, $inchash, $dl_shared_objects, $incarray);
 384
 385             my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
 386             _merge_rv($rv_sub, $rv);
 387         }
 388     }
 389     elsif ($execute) {
 390         my $excarray = (ref($execute)) ? $execute : [@$files];
 391         my $exc;
 392         my $first_flag = 1;
 393         foreach $exc (@$excarray) {
 394             ($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
 395             _execute(
 396                 $perl, $exc, $inchash, $dl_shared_objects, $incarray,
 397                 $first_flag
 398             );
 399             $first_flag = 0;
 400         }
 401
 402         my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
 403         _merge_rv($rv_sub, $rv);
 404     }
 405
 406     return ($rv);
 407 }
 408
 409 sub scan_line {
 410     my $line = shift;
 411     my %found;
 412
 413     return '__END__' if $line =~ /^__(?:END|DATA)__$/;
 414     return '__POD__' if $line =~ /^=\w/;
 415
 416     $line =~ s/\s*#.*$//;
 417     $line =~ s/[\\\/]+/\//g;
 418
 419     foreach (split(/;/, $line)) {
 420         if (/^\s*package\s+(\w+);/) {
 421             $CurrentPackage = $1;
 422             $CurrentPackage =~ s{::}{/}g;
 423             return;
 424         }
 425         return if /^\s*(use|require)\s+[\d\._]+/;
 426
 427         if (my ($libs) = /\b(?:use\s+lib\s+|(?:unshift|push)\W+\@INC\W+)(.+)/)
 428         {
 429             my $archname =
 430               defined($Config{archname}) ? $Config{archname} : '';
 431             my $ver = defined($Config{version}) ? $Config{version} : '';
 432             foreach (grep(/\w/, split(/["';() ]/, $libs))) {
 433                 unshift(@INC, "$_/$ver")           if -d "$_/$ver";
 434                 unshift(@INC, "$_/$archname")      if -d "$_/$archname";
 435                 unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname";
 436             }
 437             next;
 438         }
 439
 440         $found{$_}++ for scan_chunk($_);
 441     }
 442
 443     return sort keys %found;
 444 }
 445
 446 sub scan_chunk {
 447     my $chunk = shift;
 448
 449     # Module name extraction heuristics {{{
 450     my $module = eval {
 451         $_ = $chunk;
 452
 453         return [ 'base.pm',
 454             map { s{::}{/}g; "$_.pm" }
 455               grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 456           if /^\s* use \s+ base \s+ (.*)/sx;
 457
 458         return [ 'Class/Autouse.pm',
 459             map { s{::}{/}g; "$_.pm" }
 460               grep { length and !/^:|^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 461           if /^\s* use \s+ Class::Autouse \s+ (.*)/sx
 462               or /^\s* Class::Autouse \s* -> \s* autouse \s* (.*)/sx;
 463
 464         return [ 'POE.pm',
 465             map { s{::}{/}g; "POE/$_.pm" }
 466               grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 467           if /^\s* use \s+ POE \s+ (.*)/sx;
 468
 469         return [ 'encoding.pm',
 470             map { _find_encoding($_) }
 471               grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 472           if /^\s* use \s+ encoding \s+ (.*)/sx;
 473
 474         return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']+)/;
 475         return $1
 476           if /(?:^|\s)(?:use|no|require)\s+\(\s*([\w:\.\-\\\/\"\']+)\s*\)/;
 477
 478         if (   s/(?:^|\s)eval\s+\"([^\"]+)\"/$1/
 479             or s/(?:^|\s)eval\s*\(\s*\"([^\"]+)\"\s*\)/$1/)
 480         {
 481             return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']*)/;
 482         }
 483
 484         return "File/Glob.pm" if /<[^>]*[^\$\w>][^>]*>/;
 485         return "DBD/$1.pm"    if /\b[Dd][Bb][Ii]:(\w+):/;
 486         if (/(?:(:encoding)|\b(?:en|de)code)\(\s*['"]?([-\w]+)/) {
 487             my $mod = _find_encoding($2);
 488             return [ 'PerlIO.pm', $mod ] if $1 and $mod;
 489             return $mod if $mod;
 490         }
 491         return $1 if /(?:^|\s)(?:do|require)\s+[^"]*"(.*?)"/;
 492         return $1 if /(?:^|\s)(?:do|require)\s+[^']*'(.*?)'/;
 493         return $1 if /[^\$]\b([\w:]+)->\w/ and $1 ne 'Tk';
 494         return $1 if /\b(\w[\w:]*)::\w+\(/;
 495
 496         if ($SeenTk) {
 497             my @modules;
 498             while (/->\s*([A-Z]\w+)/g) {
 499                 push @modules, "Tk/$1.pm";
 500             }
 501             while (/->\s*Scrolled\W+([A-Z]\w+)/g) {
 502                 push @modules, "Tk/$1.pm";
 503                 push @modules, "Tk/Scrollbar.pm";
 504             }
 505             return \@modules;
 506         }
 507         return;
 508     };
 509
 510     # }}}
 511
 512     return unless defined($module);
 513     return wantarray ? @$module : $module->[0] if ref($module);
 514
 515     $module =~ s/^['"]//;
 516     return unless $module =~ /^\w/;
 517
 518     $module =~ s/\W+$//;
 519     $module =~ s/::/\//g;
 520     return if $module =~ /^(?:[\d\._]+|'.*[^']|".*[^"])$/;
 521
 522     $module .= ".pm" unless $module =~ /\./;
 523     return $module;
 524 }
 525
 526 sub _find_encoding {
 527     return unless $] >= 5.008 and eval { require Encode; %Encode::ExtModule };
 528
 529     my $mod = $Encode::ExtModule{ Encode::find_encoding($_[0])->name }
 530       or return;
 531     $mod =~ s{::}{/}g;
 532     return "$mod.pm";
 533 }
 534
 535 sub _add_info {
 536     my ($rv, $module, $file, $used_by, $type) = @_;
 537     return unless defined($module) and defined($file);
 538
 539     $rv->{$module} ||= {
 540         file => $file,
 541         key  => $module,
 542         type => $type,
 543     };
 544
 545     push @{ $rv->{$module}{used_by} }, $used_by
 546       if defined($used_by)
 547       and $used_by ne $module
 548       and !grep { $_ eq $used_by } @{ $rv->{$module}{used_by} };
 549 }
 550
 551 sub add_deps {
 552     my %args =
 553       ((@_ and $_[0] =~ /^(?:modules|rv|used_by)$/)
 554         ? @_
 555         : (rv => (ref($_[0]) ? shift(@_) : undef), modules => [@_]));
 556
 557     my $rv   = $args{rv}   || {};
 558     my $skip = $args{skip} || {};
 559     my $used_by = $args{used_by};
 560
 561     foreach my $module (@{ $args{modules} }) {
 562         next if exists $rv->{$module};
 563
 564         my $file = _find_in_inc($module) or next;
 565         next if $skip->{$file};
 566         next if is_insensitive_fs() and $skip->{lc($file)};
 567
 568         my $type = 'module';
 569         $type = 'data' unless $file =~ /\.p[mh]$/i;
 570         _add_info($rv, $module, $file, $used_by, $type);
 571
 572         if ($module =~ /(.*?([^\/]*))\.p[mh]$/i) {
 573             my ($path, $basename) = ($1, $2);
 574
 575             foreach (_glob_in_inc("auto/$path")) {
 576                 next if $skip->{$_->{file}};
 577                 next if is_insensitive_fs() and $skip->{lc($_->{file})};
 578                 next if $_->{file} =~ m{\bauto/$path/.*/};  # weed out subdirs
 579                 next if $_->{name} =~ m/(?:^|\/)\.(?:exists|packlist)$/;
 580                 my $ext = lc($1) if $_->{name} =~ /(\.[^.]+)$/;
 581                 next if $ext eq lc(lib_ext());
 582                 my $type = 'shared' if $ext eq lc(dl_ext());
 583                 $type = 'autoload' if $ext eq '.ix' or $ext eq '.al';
 584                 $type ||= 'data';
 585
 586                 _add_info($rv, "auto/$path/$_->{name}", $_->{file}, $module,
 587                     $type);
 588             }
 589         }
 590     }
 591
 592     return $rv;
 593 }
 594
 595 sub _find_in_inc {
 596     my $file = shift;
 597
 598     # absolute file names
 599     return $file if -f $file;
 600
 601     foreach my $dir (grep !/\bBSDPAN\b/, @INC) {
 602         return "$dir/$file" if -f "$dir/$file";
 603     }
 604     return;
 605 }
 606
 607 sub _glob_in_inc {
 608     my $subdir  = shift;
 609     my $pm_only = shift;
 610     my @files;
 611
 612     require File::Find;
 613
 614     foreach my $dir (map "$_/$subdir", grep !/\bBSDPAN\b/, @INC) {
 615         next unless -d $dir;
 616         File::Find::find({
 617                 "wanted" => sub {
 618                     my $name = $File::Find::name;
 619                     $name =~ s!^\Q$dir\E/!!;
 620                     return if $pm_only and lc($name) !~ /\.p[mh]$/i;
 621                     push @files, $pm_only
 622                         ? "$subdir/$name"
 623                         : {             file => $File::Find::name,
 624                                         name => $name,
 625                                     }
 626                     if -f;
 627                 },
 628                 "untaint" => 1,
 629                 "untaint_skip" => 1,
 630                 "untaint_pattern" => qr|^([-+@\w./]+)$|
 631                 }, $dir
 632         );
 633     }
 634
 635     return @files;
 636 }
 637
 638 # App::Packer compatibility functions
 639
 640 sub new {
 641     my ($class, $self) = @_;
 642     return bless($self ||= {}, $class);
 643 }
 644
 645 sub set_file {
 646     my $self = shift;
 647     foreach my $script (@_) {
 648         my $basename = $script;
 649         $basename =~ s/.*\///;
 650         $self->{main} = {
 651             key  => $basename,
 652             file => $script,
 653         };
 654     }
 655 }
 656
 657 sub set_options {
 658     my $self = shift;
 659     my %args = @_;
 660     foreach my $module (@{ $args{add_modules} }) {
 661         $module =~ s/::/\//g;
 662         $module .= '.pm' unless $module =~ /\.p[mh]$/i;
 663         my $file = _find_in_inc($module) or next;
 664         $self->{files}{$module} = $file;
 665     }
 666 }
 667
 668 sub calculate_info {
 669     my $self = shift;
 670     my $rv   = scan_deps(
 671         keys  => [ $self->{main}{key}, sort keys %{ $self->{files} }, ],
 672         files => [ $self->{main}{file},
 673             map { $self->{files}{$_} } sort keys %{ $self->{files} },
 674         ],
 675         recurse => 1,
 676     );
 677
 678     my $info = {
 679         main => {  file     => $self->{main}{file},
 680             store_as => $self->{main}{key},
 681         },
 682     };
 683
 684     my %cache = ($self->{main}{key} => $info->{main});
 685     foreach my $key (sort keys %{ $self->{files} }) {
 686         my $file = $self->{files}{$key};
 687
 688         $cache{$key} = $info->{modules}{$key} = {
 689             file     => $file,
 690             store_as => $key,
 691             used_by  => [ $self->{main}{key} ],
 692         };
 693     }
 694
 695     foreach my $key (sort keys %{$rv}) {
 696         my $val = $rv->{$key};
 697         if ($cache{ $val->{key} }) {
 698             push @{ $info->{ $val->{type} }->{ $val->{key} }->{used_by} },
 699               @{ $val->{used_by} };
 700         }
 701         else {
 702             $cache{ $val->{key} } = $info->{ $val->{type} }->{ $val->{key} } =
 703               {        file     => $val->{file},
 704                 store_as => $val->{key},
 705                 used_by  => $val->{used_by},
 706               };
 707         }
 708     }
 709
 710     $self->{info} = { main => $info->{main} };
 711
 712     foreach my $type (sort keys %{$info}) {
 713         next if $type eq 'main';
 714
 715         my @val;
 716         if (UNIVERSAL::isa($info->{$type}, 'HASH')) {
 717             foreach my $val (sort values %{ $info->{$type} }) {
 718                 @{ $val->{used_by} } = map $cache{$_} || "!!$_!!",
 719                   @{ $val->{used_by} };
 720                 push @val, $val;
 721             }
 722         }
 723
 724         $type = 'modules' if $type eq 'module';
 725         $self->{info}{$type} = \@val;
 726     }
 727 }
 728
 729 sub get_files {
 730     my $self = shift;
 731     return $self->{info};
 732 }
 733
 734 # scan_deps_runtime utility functions
 735
 736 sub _compile {
 737     my ($perl, $file, $inchash, $dl_shared_objects, $incarray) = @_;
 738
 739     my $fname = File::Temp::mktemp("$file.XXXXXX");
 740     my $fhin  = FileHandle->new($file) or die "Couldn't open $file\n";
 741     my $fhout = FileHandle->new("> $fname") or die "Couldn't open $fname\n";
 742
 743     my $line = do { local $/; <$fhin> };
 744     $line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
 745     $line =~ s/^(.*?)((?:[\r\n]+__(?:DATA|END)__[\r\n]+)|$)/
 746 use Module::ScanDeps::DataFeed '$fname.out';
 747 sub {
 748 $1
 749 }
 750 $2/s;
 751     $fhout->print($line);
 752     $fhout->close;
 753     $fhin->close;
 754
 755     system($perl, $fname);
 756
 757     _extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
 758     unlink("$fname");
 759     unlink("$fname.out");
 760 }
 761
 762 sub _execute {
 763     my ($perl, $file, $inchash, $dl_shared_objects, $incarray, $firstflag) = @_;
 764
 765     $DB::single = $DB::single = 1;
 766
 767     my $fname = _abs_path(File::Temp::mktemp("$file.XXXXXX"));
 768     my $fhin  = FileHandle->new($file) or die "Couldn't open $file";
 769     my $fhout = FileHandle->new("> $fname") or die "Couldn't open $fname";
 770
 771     my $line = do { local $/; <$fhin> };
 772     $line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
 773     $line = "use Module::ScanDeps::DataFeed '$fname.out';\n" . $line;
 774     $fhout->print($line);
 775     $fhout->close;
 776     $fhin->close;
 777
 778     File::Path::rmtree( ['_Inline'], 0, 1); # XXX hack
 779     system($perl, $fname) == 0 or die "SYSTEM ERROR in executing $file: $?";
 780
 781     _extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
 782     unlink("$fname");
 783     unlink("$fname.out");
 784 }
 785
 786 sub _make_rv {
 787     my ($inchash, $dl_shared_objects, $inc_array) = @_;
 788
 789     my $rv = {};
 790     my @newinc = map(quotemeta($_), @$inc_array);
 791     my $inc = join('|', sort { length($b) <=> length($a) } @newinc);
 792
 793     require File::Spec;
 794
 795     my $key;
 796     foreach $key (keys(%$inchash)) {
 797         my $newkey = $key;
 798         $newkey =~ s"^(?:(?:$inc)/?)""sg if File::Spec->file_name_is_absolute($newkey);
 799
 800         $rv->{$newkey} = {
 801             'used_by' => [],
 802             'file'    => $inchash->{$key},
 803             'type'    => _gettype($inchash->{$key}),
 804             'key'     => $key
 805         };
 806     }
 807
 808     my $dl_file;
 809     foreach $dl_file (@$dl_shared_objects) {
 810         my $key = $dl_file;
 811         $key =~ s"^(?:(?:$inc)/?)""s;
 812
 813         $rv->{$key} = {
 814             'used_by' => [],
 815             'file'    => $dl_file,
 816             'type'    => 'shared',
 817             'key'     => $key
 818         };
 819     }
 820
 821     return $rv;
 822 }
 823
 824 sub _extract_info {
 825     my ($fname, $inchash, $dl_shared_objects, $incarray) = @_;
 826
 827     use vars qw(%inchash @dl_shared_objects @incarray);
 828     my $fh = FileHandle->new($fname) or die "Couldn't open $fname";
 829     my $line = do { local $/; <$fh> };
 830     $fh->close;
 831
 832     eval $line;
 833
 834     $inchash->{$_} = $inchash{$_} for keys %inchash;
 835     @$dl_shared_objects = @dl_shared_objects;
 836     @$incarray          = @incarray;
 837 }
 838
 839 sub _gettype {
 840     my $name = shift;
 841     my $dlext = quotemeta(dl_ext());
 842
 843     return 'autoload' if $name =~ /(?:\.ix|\.al|\.bs)$/i;
 844     return 'module'   if $name =~ /\.p[mh]$/i;
 845     return 'shared'   if $name =~ /\.$dlext$/i;
 846     return 'data';
 847 }
 848
 849 sub _merge_rv {
 850     my ($rv_sub, $rv) = @_;
 851
 852     my $key;
 853     foreach $key (keys(%$rv_sub)) {
 854         my %mark;
 855         if ($rv->{$key} and _not_dup($key, $rv, $rv_sub)) {
 856             warn "different modules for file: $key: were found" .
 857                  "(using the version) after the '=>': ".
 858                  "$rv->{$key}{file} => $rv_sub->{$key}{file}\n";
 859
 860             $rv->{$key}{used_by} = [
 861                 grep (!$mark{$_}++,
 862                     @{ $rv->{$key}{used_by} },
 863                     @{ $rv_sub->{$key}{used_by} })
 864             ];
 865             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
 866             $rv->{$key}{file} = $rv_sub->{$key}{file};
 867         }
 868         elsif ($rv->{$key}) {
 869             $rv->{$key}{used_by} = [
 870                 grep (!$mark{$_}++,
 871                     @{ $rv->{$key}{used_by} },
 872                     @{ $rv_sub->{$key}{used_by} })
 873             ];
 874             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
 875         }
 876         else {
 877             $rv->{$key} = {
 878                 used_by => [ @{ $rv_sub->{$key}{used_by} } ],
 879                 file    => $rv_sub->{$key}{file},
 880                 key     => $rv_sub->{$key}{key},
 881                 type    => $rv_sub->{$key}{type}
 882             };
 883
 884             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
 885         }
 886     }
 887 }
 888
 889 sub _not_dup {
 890     my ($key, $rv1, $rv2) = @_;
 891     (_abs_path($rv1->{$key}{file}) ne _abs_path($rv2->{$key}{file}));
 892 }
 893
 894 sub _abs_path {
 895     return join(
 896         '/',
 897         Cwd::abs_path(File::Basename::dirname($_[0])),
 898         File::Basename::basename($_[0]),
 899     );
 900 }
 901
 902 #####################################################
 903 ### Actual perldeps.pl code starts here.
 904
 905 # Print usage information
 906 sub
 907 print_usage_info($)
 908 {
 909     my $code = shift || 0;
 910     my ($leader, $underbar);
 911
 912     print "\n";
 913     $leader = "$0 Usage Information";
 914     $underbar = $leader;
 915     $underbar =~ s/./-/g;
 916     print "$leader\n$underbar\n";
 917     print "\n";
 918     print "  Syntax:   $0 [ options ] [ path(s)/file(s) ]\n";
 919     print "\n";
 920     print "    -h --help                        Show this usage information\n";
 921     print "    -v --version                     Show version and copyright\n";
 922     print "    -d --debug                       Turn on debugging\n";
 923     print "    -p --provides                    Find things provided by path(s)/file(s)\n";
 924     print "    -r --requires                    Find things required by path(s)/file(s)\n";
 925     #print "                                     \n";
 926     print "\nNOTE:  Path(s)/file(s) can also be specified on STDIN.  Default is \@INC.\n\n";
 927     exit($code);
 928 }
 929
 930 # Locate perl modules (*.pm) in given locations.
 931 sub
 932 find_perl_modules(@)
 933 {
 934     my @locations = @_;
 935     my %modules;
 936
 937     foreach my $loc (@locations) {
 938         if (-f $loc) {
 939             # It's a file.  Assume it's a Perl module.
 940             #print "Found module:  $loc.\n";
 941             $modules{$loc} = 1;
 942         } elsif (-d $loc) {
 943             my @tmp;
 944
 945             # Recurse the directory tree looking for all modules inside it.
 946             &File::Find::find({
 947                 "wanted" => sub {
 948                     if ((-s _) && (substr($File::Find::fullname, -3, 3) eq ".pm")) {
 949                         push @tmp, $File::Find::fullname;
 950                     }
 951                 },
 952                 "follow_fast" => 1,
 953                 "no_chdir" => 1,
 954                 "untaint" => 1,
 955                 "untaint_skip" => 1,
 956                 "untaint_pattern" => qr|^([-+@\w./]+)$|
 957                 }, $loc);
 958
 959             # @tmp is now a list with all non-empty *.pm files in and under $loc.
 960             # Untaint and save in %modules hash.
 961             foreach my $module (@tmp) {
 962                 if ($module =~ /^([-+@\w.\/]+)$/) {
 963                     $modules{$1} = 1;
 964                     #print "Found module:  $1\n";
 965                 }
 966             }
 967         } else {
 968             # Something wicked this way comes.
 969             print STDERR "$0:  Error:  Don't know what to do with location \"$loc\"\n";
 970         }
 971     }
 972     return keys(%modules);
 973 }
 974
 975 # Generate an RPM-style "Provides:" list for the given modules.
 976 sub
 977 find_provides(@)
 978 {
 979     my @modules = @_;
 980     my @prov;
 981
 982     foreach my $mod (@modules) {
 983         my (@contents, @pkgs);
 984         my $mod_path;
 985         local *MOD;
 986
 987         $mod_path = dirname($mod);
 988         if (!open(MOD, $mod)) {
 989             warn "Unable to read module $mod -- $!\n";
 990             next;
 991         }
 992         @contents = <MOD>;
 993         if (!close(MOD)) {
 994             warn "Unable to close module $mod -- $!\n";
 995         }
 996
 997         if (!scalar(grep { $_ eq $mod_path } @INC)) {
 998             push @INC, $mod_path;
 999         }
1000         foreach my $line (grep { $_ =~ /^\s*package\s+/ } @contents) {
1001             if ($line =~ /^\s*package\s+([^\;\s]+)\s*\;/) {
1002                 push @pkgs, $1;
1003             }
1004         }
1005
1006         # Now we have a list of packages.  Load up the modules and get their versions.
1007         foreach my $pkg (@pkgs) {
1008             my $ret;
1009             local ($SIG{"__WARN__"}, $SIG{"__DIE__"});
1010
1011             # Make sure eval() can't display warnings/errors.
1012             $SIG{"__DIE__"} = $SIG{"__WARN__"} = sub {0;};
1013             $ret = eval("no strict ('vars', 'subs', 'refs'); use $pkg (); return $pkg->VERSION || 0.0;");
1014             if ($@) {
1015                 dprint "Unable to parse version number from $pkg -- $@.  Assuming 0.\n";
1016                 $ret = 0;
1017             }
1018
1019             if (! $ret) {
1020                 $ret = 0;
1021             }
1022             push @prov, "perl($pkg) = $ret";
1023         }
1024     }
1025     printf("Provides:  %s\n", join(", ", sort(@prov)));
1026 }
1027
1028 # Generate an RPM-style "Requires:" list for the given modules.
1029 sub
1030 find_requires(@)
1031 {
1032     my @modules = @_;
1033     my @reqs;
1034     my $reqs;
1035
1036     $reqs = &scan_deps("files" => \@modules, "recurse" => 0);
1037     foreach my $key (grep { $reqs->{$_}{"type"} eq "module" } sort(keys(%{$reqs}))) {
1038         if (substr($key, -3, 3) eq ".pm") {
1039             $key = substr($key, 0, -3);
1040         }
1041         $key =~ s!/!::!g;
1042         push @reqs, "perl($key)";
1043     }
1044     printf("Requires:  %s\n", join(", ", @reqs));
1045 }
1046
1047 sub
1048 main()
1049 {
1050     my $VERSION = '1.0';
1051     my (@locations, @modules);
1052     my %OPTION;
1053
1054     # For taint checks
1055     delete @ENV{("IFS", "CDPATH", "ENV", "BASH_ENV")};
1056     $ENV{"PATH"} = "/bin:/usr/bin:/sbin:/usr/sbin:/etc:/usr/ucb";
1057     foreach my $shell ("/bin/bash", "/usr/bin/ksh", "/bin/ksh", "/bin/sh", "/sbin/sh") {
1058         if (-f $shell) {
1059             $ENV{"SHELL"} = $shell;
1060             last;
1061         }
1062     }
1063
1064     $ENV{"LANG"} = "C" if (! $ENV{"LANG"});
1065     umask 022;
1066     select STDERR; $| = 1;
1067     select STDOUT; $| = 1;
1068
1069     Getopt::Long::Configure("no_getopt_compat", "bundling", "no_ignore_case");
1070     Getopt::Long::GetOptions(\%OPTION, "debug|d!", "help|h", "version|v", "provides|p", "requires|r");
1071
1072     # Post-parse the options stuff
1073     select STDOUT; $| = 1;
1074     if ($OPTION{"version"}) {
1075         # Do not edit this variable.  It is updated automatically by CVS when you commit
1076         my $rcs_info = 'CVS Revision $Revision: 1.6 $ created on $Date: 2006/04/04 20:12:03 $ by $Author: mej $ ';
1077
1078         $rcs_info =~ s/\$\s*Revision: (\S+) \$/$1/;
1079         $rcs_info =~ s/\$\s*Date: (\S+) (\S+) \$/$1 at $2/;
1080         $rcs_info =~ s/\$\s*Author: (\S+) \$ /$1/;
1081         print "\n";
1082         print "perldeps.pl $VERSION by Michael Jennings <mej\@eterm.org>\n";
1083         print "Copyright (c) 2005-2006, Michael Jennings\n";
1084         print "  ($rcs_info)\n";
1085         print "\n";
1086         return 0;
1087     } elsif ($OPTION{"help"}) {
1088         &print_usage_info(0);   # Never returns
1089     }
1090
1091     push @locations, @ARGV;
1092     if (!scalar(@ARGV) && !(-t STDIN)) {
1093         @locations = <STDIN>;
1094     }
1095     if (!scalar(@locations)) {
1096         @locations = @INC;
1097     }
1098
1099     if (!($OPTION{"provides"} || $OPTION{"requires"})) {
1100         &print_usage_info(-1);   # Never returns
1101     }
1102
1103     # Catch bogus warning messages like "A thread exited while 2 threads were running"
1104     $SIG{"__DIE__"} = $SIG{"__WARN__"} = sub {0;};
1105
1106     @modules = &find_perl_modules(@locations);
1107     if ($OPTION{"provides"}) {
1108         &find_provides(@modules);
1109     }
1110     if ($OPTION{"requires"}) {
1111         &find_requires(@modules);
1112     }
1113     return 0;
1114 }
1115
1116 exit &main();