lang/perl/files/Module/ScanDeps.pm

   1 package Module::ScanDeps;
   2
   3 use 5.004;
   4 use strict;
   5 use vars qw( $VERSION @EXPORT @EXPORT_OK $CurrentPackage );
   6
   7 $VERSION   = '0.62';
   8 @EXPORT    = qw( scan_deps scan_deps_runtime );
   9 @EXPORT_OK = qw( scan_line scan_chunk add_deps scan_deps_runtime );
  10
  11 use Config;
  12 use Exporter;
  13 use base 'Exporter';
  14 use constant dl_ext  => ".$Config{dlext}";
  15 use constant lib_ext => $Config{lib_ext};
  16 use constant is_insensitive_fs => (
  17     -s $0
  18         and (-s lc($0) || -1) == (-s uc($0) || -1)
  19         and (-s lc($0) || -1) == -s $0
  20 );
  21
  22 use Cwd ();
  23 use File::Path ();
  24 use File::Temp ();
  25 use File::Basename ();
  26 use FileHandle;
  27
  28 =head1 NAME
  29
  30 Module::ScanDeps - Recursively scan Perl code for dependencies
  31
  32 =head1 VERSION
  33
  34 This document describes version 0.61 of Module::ScanDeps, released
  35 June 30, 2006.
  36
  37 =head1 SYNOPSIS
  38
  39 Via the command-line program L<scandeps.pl>:
  40
  41     % scandeps.pl *.pm          # Print PREREQ_PM section for *.pm
  42     % scandeps.pl -e "use utf8" # Read script from command line
  43     % scandeps.pl -B *.pm       # Include core modules
  44     % scandeps.pl -V *.pm       # Show autoload/shared/data files
  45
  46 Used in a program;
  47
  48     use Module::ScanDeps;
  49
  50     # standard usage
  51     my $hash_ref = scan_deps(
  52         files   => [ 'a.pl', 'b.pl' ],
  53         recurse => 1,
  54     );
  55
  56     # shorthand; assume recurse == 1
  57     my $hash_ref = scan_deps( 'a.pl', 'b.pl' );
  58
  59     # App::Packer::Frontend compatible interface
  60     # see App::Packer::Frontend for the structure returned by get_files
  61     my $scan = Module::ScanDeps->new;
  62     $scan->set_file( 'a.pl' );
  63     $scan->set_options( add_modules => [ 'Test::More' ] );
  64     $scan->calculate_info;
  65     my $files = $scan->get_files;
  66
  67 =head1 DESCRIPTION
  68
  69 This module scans potential modules used by perl programs, and returns a
  70 hash reference; its keys are the module names as appears in C<%INC>
  71 (e.g. C<Test/More.pm>); the values are hash references with this structure:
  72
  73     {
  74         file    => '/usr/local/lib/perl5/5.8.0/Test/More.pm',
  75         key     => 'Test/More.pm',
  76         type    => 'module',    # or 'autoload', 'data', 'shared'
  77         used_by => [ 'Test/Simple.pm', ... ],
  78     }
  79
  80 One function, C<scan_deps>, is exported by default.  Three other
  81 functions (C<scan_line>, C<scan_chunk>, C<add_deps>) are exported upon
  82 request.
  83
  84 Users of B<App::Packer> may also use this module as the dependency-checking
  85 frontend, by tweaking their F<p2e.pl> like below:
  86
  87     use Module::ScanDeps;
  88     ...
  89     my $packer = App::Packer->new( frontend => 'Module::ScanDeps' );
  90     ...
  91
  92 Please see L<App::Packer::Frontend> for detailed explanation on
  93 the structure returned by C<get_files>.
  94
  95 =head2 B<scan_deps>
  96
  97     $rv_ref = scan_deps(
  98         files   => \@files,     recurse => $recurse,
  99         rv      => \%rv,        skip    => \%skip,
 100         compile => $compile,    execute => $execute,
 101     );
 102     $rv_ref = scan_deps(@files); # shorthand, with recurse => 1
 103
 104 This function scans each file in C<@files>, registering their
 105 dependencies into C<%rv>, and returns a reference to the updated
 106 C<%rv>.  The meaning of keys and values are explained above.
 107
 108 If C<$recurse> is true, C<scan_deps> will call itself recursively,
 109 to perform a breadth-first search on text files (as defined by the
 110 -T operator) found in C<%rv>.
 111
 112 If the C<\%skip> is specified, files that exists as its keys are
 113 skipped.  This is used internally to avoid infinite recursion.
 114
 115 If C<$compile> or C<$execute> is true, runs C<files> in either
 116 compile-only or normal mode, then inspects their C<%INC> after
 117 termination to determine additional runtime dependencies.
 118
 119 If C<$execute> is an array reference, runs the files contained
 120 in it instead of C<@files>.
 121
 122 =head2 B<scan_deps_runtime>
 123
 124 Like B<scan_deps>, but skips the static scanning part.
 125
 126 =head2 B<scan_line>
 127
 128     @modules = scan_line($line);
 129
 130 Splits a line into chunks (currently with the semicolon characters), and
 131 return the union of C<scan_chunk> calls of them.
 132
 133 If the line is C<__END__> or C<__DATA__>, a single C<__END__> element is
 134 returned to signify the end of the program.
 135
 136 Similarly, it returns a single C<__POD__> if the line matches C</^=\w/>;
 137 the caller is responsible for skipping appropriate number of lines
 138 until C<=cut>, before calling C<scan_line> again.
 139
 140 =head2 B<scan_chunk>
 141
 142     $module = scan_chunk($chunk);
 143     @modules = scan_chunk($chunk);
 144
 145 Apply various heuristics to C<$chunk> to find and return the module
 146 name(s) it contains.  In scalar context, returns only the first module
 147 or C<undef>.
 148
 149 =head2 B<add_deps>
 150
 151     $rv_ref = add_deps( rv => \%rv, modules => \@modules );
 152     $rv_ref = add_deps( @modules ); # shorthand, without rv
 153
 154 Resolves a list of module names to its actual on-disk location, by
 155 finding in C<@INC>; modules that cannot be found are skipped.
 156
 157 This function populates the C<%rv> hash with module/filename pairs, and
 158 returns a reference to it.
 159
 160 =head1 CAVEATS
 161
 162 This module intentially ignores the B<BSDPAN> hack on FreeBSD -- the
 163 additional directory is removed from C<@INC> altogether.
 164
 165 The static-scanning heuristic is not likely to be 100% accurate, especially
 166 on modules that dynamically load other modules.
 167
 168 Chunks that span multiple lines are not handled correctly.  For example,
 169 this one works:
 170
 171     use base 'Foo::Bar';
 172
 173 But this one does not:
 174
 175     use base
 176         'Foo::Bar';
 177
 178 =cut
 179
 180 my $SeenTk;
 181
 182 # Pre-loaded module dependencies {{{
 183 my %Preload = (
 184     'AnyDBM_File.pm'  => [qw( SDBM_File.pm )],
 185     'Authen/SASL.pm'  => 'sub',
 186     'Bio/AlignIO.pm'  => 'sub',
 187     'Bio/Assembly/IO.pm'  => 'sub',
 188     'Bio/Biblio/IO.pm'  => 'sub',
 189     'Bio/ClusterIO.pm'  => 'sub',
 190     'Bio/CodonUsage/IO.pm'  => 'sub',
 191     'Bio/DB/Biblio.pm'  => 'sub',
 192     'Bio/DB/Flat.pm'  => 'sub',
 193     'Bio/DB/GFF.pm'  => 'sub',
 194     'Bio/DB/Taxonomy.pm'  => 'sub',
 195     'Bio/Graphics/Glyph.pm'  => 'sub',
 196     'Bio/MapIO.pm'  => 'sub',
 197     'Bio/Matrix/IO.pm'  => 'sub',
 198     'Bio/Matrix/PSM/IO.pm'  => 'sub',
 199     'Bio/OntologyIO.pm'  => 'sub',
 200     'Bio/PopGen/IO.pm'  => 'sub',
 201     'Bio/Restriction/IO.pm'  => 'sub',
 202     'Bio/Root/IO.pm'  => 'sub',
 203     'Bio/SearchIO.pm'  => 'sub',
 204     'Bio/SeqIO.pm'  => 'sub',
 205     'Bio/Structure/IO.pm'  => 'sub',
 206     'Bio/TreeIO.pm'  => 'sub',
 207     'Bio/LiveSeq/IO.pm'  => 'sub',
 208     'Bio/Variation/IO.pm'  => 'sub',
 209     'Crypt/Random.pm' => sub {
 210         _glob_in_inc('Crypt/Random/Provider', 1);
 211     },
 212     'Crypt/Random/Generator.pm' => sub {
 213         _glob_in_inc('Crypt/Random/Provider', 1);
 214     },
 215     'DBI.pm' => sub {
 216         grep !/\bProxy\b/, _glob_in_inc('DBD', 1);
 217     },
 218     'DBIx/SearchBuilder.pm' => 'sub',
 219     'DBIx/ReportBuilder.pm' => 'sub',
 220     'Device/ParallelPort.pm' => 'sub',
 221     'Device/SerialPort.pm' => [ qw(
 222         termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
 223     ) ],
 224     'ExtUtils/MakeMaker.pm' => sub {
 225         grep /\bMM_/, _glob_in_inc('ExtUtils', 1);
 226     },
 227     'File/Basename.pm' => [qw( re.pm )],
 228     'File/Spec.pm'     => sub {
 229         require File::Spec;
 230         map { my $name = $_; $name =~ s!::!/!g; "$name.pm" } @File::Spec::ISA;
 231     },
 232     'HTTP/Message.pm' => [ qw(
 233         URI/URL.pm          URI.pm
 234     ) ],
 235     'IO.pm' => [ qw(
 236         IO/Handle.pm        IO/Seekable.pm      IO/File.pm
 237         IO/Pipe.pm          IO/Socket.pm        IO/Dir.pm
 238     ) ],
 239     'IO/Socket.pm'     => [qw( IO/Socket/UNIX.pm )],
 240     'LWP/UserAgent.pm' => [ qw(
 241         URI/URL.pm          URI/http.pm         LWP/Protocol/http.pm
 242         LWP/Protocol/https.pm
 243     ), _glob_in_inc("LWP/Authen", 1) ],
 244     'Locale/Maketext/Lexicon.pm'    => 'sub',
 245     'Locale/Maketext/GutsLoader.pm' => [qw( Locale/Maketext/Guts.pm )],
 246     'Mail/Audit.pm'                => 'sub',
 247     'Math/BigInt.pm'                => 'sub',
 248     'Math/BigFloat.pm'              => 'sub',
 249         'Math/Symbolic.pm'              => 'sub',
 250     'Module/Build.pm'               => 'sub',
 251     'Module/Pluggable.pm'           => sub {
 252         _glob_in_inc('$CurrentPackage/Plugin', 1);
 253     },
 254     'MIME/Decoder.pm'               => 'sub',
 255     'Net/DNS/RR.pm'                 => 'sub',
 256     'Net/FTP.pm'                    => 'sub',
 257     'Net/SSH/Perl.pm'               => 'sub',
 258     'PDF/API2/Resource/Font.pm'     => 'sub',
 259     'PDF/API2/Basic/TTF/Font.pm'    => sub {
 260         _glob_in_inc('PDF/API2/Basic/TTF', 1);
 261     },
 262     'PDF/Writer.pm'                 => 'sub',
 263     'POE'                           => [ qw(
 264         POE/Kernel.pm POE/Session.pm
 265     ) ],
 266     'POE/Kernel.pm'                    => [
 267         map "POE/Resource/$_.pm", qw(
 268             Aliases Events Extrefs FileHandles
 269             SIDs Sessions Signals Statistics
 270         )
 271     ],
 272     'Parse/AFP.pm'                  => 'sub',
 273     'Parse/Binary.pm'               => 'sub',
 274     'Regexp/Common.pm'              => 'sub',
 275     'SerialJunk.pm' => [ qw(
 276         termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
 277     ) ],
 278     'SOAP/Lite.pm'                  => sub {
 279         (($] >= 5.008 ? ('utf8.pm') : ()), _glob_in_inc('SOAP/Transport', 1));
 280     },
 281     'SQL/Parser.pm' => sub {
 282         _glob_in_inc('SQL/Dialects', 1);
 283     },
 284     'SVK/Command.pm' => sub {
 285         _glob_in_inc('SVK', 1);
 286     },
 287     'SVN/Core.pm' => sub {
 288         _glob_in_inc('SVN', 1),
 289         map "auto/SVN/$_->{name}", _glob_in_inc('auto/SVN'),
 290     },
 291     'Template.pm'      => 'sub',
 292     'Term/ReadLine.pm' => 'sub',
 293         'Test/Deep.pm'     => 'sub',
 294     'Tk.pm'            => sub {
 295         $SeenTk = 1;
 296         qw( Tk/FileSelect.pm Encode/Unicode.pm );
 297     },
 298     'Tk/Balloon.pm'     => [qw( Tk/balArrow.xbm )],
 299     'Tk/BrowseEntry.pm' => [qw( Tk/cbxarrow.xbm Tk/arrowdownwin.xbm )],
 300     'Tk/ColorEditor.pm' => [qw( Tk/ColorEdit.xpm )],
 301     'Tk/DragDrop/Common.pm' => sub {
 302         _glob_in_inc('Tk/DragDrop', 1),
 303     },
 304     'Tk/FBox.pm'        => [qw( Tk/folder.xpm Tk/file.xpm )],
 305     'Tk/Getopt.pm'      => [qw( Tk/openfolder.xpm Tk/win.xbm )],
 306     'Tk/Toplevel.pm'    => [qw( Tk/Wm.pm )],
 307     'URI.pm'            => sub {
 308         grep !/.\b[_A-Z]/, _glob_in_inc('URI', 1);
 309     },
 310     'Win32/EventLog.pm'    => [qw( Win32/IPC.pm )],
 311     'Win32/Exe.pm'         => 'sub',
 312     'Win32/TieRegistry.pm' => [qw( Win32API/Registry.pm )],
 313     'Win32/SystemInfo.pm'  => [qw( Win32/cpuspd.dll )],
 314     'XML/Parser.pm'        => sub {
 315         _glob_in_inc('XML/Parser/Style', 1),
 316         _glob_in_inc('XML/Parser/Encodings', 1),
 317     },
 318     'XML/Parser/Expat.pm' => sub {
 319         ($] >= 5.008) ? ('utf8.pm') : ();
 320     },
 321     'XML/SAX.pm' => [qw( XML/SAX/ParserDetails.ini ) ],
 322     'XMLRPC/Lite.pm' => sub {
 323         _glob_in_inc('XMLRPC/Transport', 1),;
 324     },
 325     'diagnostics.pm' => sub {
 326         # shamelessly taken and adapted from diagnostics.pm
 327         use Config;
 328         my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 329         if ($^O eq 'VMS') {
 330             require VMS::Filespec;
 331             $privlib = VMS::Filespec::unixify($privlib);
 332             $archlib = VMS::Filespec::unixify($archlib);
 333         }
 334
 335         for (
 336               "pod/perldiag.pod",
 337               "Pod/perldiag.pod",
 338               "pod/perldiag-$Config{version}.pod",
 339               "Pod/perldiag-$Config{version}.pod",
 340               "pods/perldiag.pod",
 341               "pods/perldiag-$Config{version}.pod",
 342         ) {
 343             return $_ if _find_in_inc($_);
 344         }
 345
 346         for (
 347               "$archlib/pods/perldiag.pod",
 348               "$privlib/pods/perldiag-$Config{version}.pod",
 349               "$privlib/pods/perldiag.pod",
 350         ) {
 351             return $_ if -f $_;
 352         }
 353
 354         return 'pod/perldiag.pod';
 355     },
 356     'utf8.pm' => [
 357         'utf8_heavy.pl', do {
 358             my $dir = 'unicore';
 359             my @subdirs = qw( To );
 360             my @files = map "$dir/lib/$_->{name}", _glob_in_inc("$dir/lib");
 361
 362             if (@files) {
 363                 # 5.8.x
 364                 push @files, (map "$dir/$_.pl", qw( Exact Canonical ));
 365             }
 366             else {
 367                 # 5.6.x
 368                 $dir = 'unicode';
 369                 @files = map "$dir/Is/$_->{name}", _glob_in_inc("$dir/Is")
 370                   or return;
 371                 push @subdirs, 'In';
 372             }
 373
 374             foreach my $subdir (@subdirs) {
 375                 foreach (_glob_in_inc("$dir/$subdir")) {
 376                     push @files, "$dir/$subdir/$_->{name}";
 377                 }
 378             }
 379             @files;
 380         }
 381     ],
 382     'charnames.pm' => [
 383         _find_in_inc('unicore/Name.pl') ? 'unicore/Name.pl' : 'unicode/Name.pl'
 384     ],
 385 );
 386
 387 # }}}
 388
 389 my $Keys = 'files|keys|recurse|rv|skip|first|execute|compile';
 390 sub scan_deps {
 391     my %args = (
 392         rv => {},
 393         (@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
 394     );
 395
 396     scan_deps_static(\%args);
 397
 398     if ($args{execute} or $args{compile}) {
 399         scan_deps_runtime(
 400             rv      => $args{rv},
 401             files   => $args{files},
 402             execute => $args{execute},
 403             compile => $args{compile},
 404             skip    => $args{skip}
 405         );
 406     }
 407
 408     return ($args{rv});
 409 }
 410
 411 sub scan_deps_static {
 412     my ($args) = @_;
 413     my ($files, $keys, $recurse, $rv, $skip, $first, $execute, $compile) =
 414       @$args{qw( files keys recurse rv skip first execute compile )};
 415
 416     $rv   ||= {};
 417     $skip ||= {};
 418
 419     foreach my $file (@{$files}) {
 420         my $key = shift @{$keys};
 421         next if $skip->{$file}++;
 422         next if is_insensitive_fs()
 423           and $file ne lc($file) and $skip->{lc($file)}++;
 424
 425         local *FH;
 426         open FH, $file or die "Cannot open $file: $!";
 427
 428         $SeenTk = 0;
 429
 430         # Line-by-line scanning
 431         LINE:
 432         while (<FH>) {
 433             chomp(my $line = $_);
 434             foreach my $pm (scan_line($line)) {
 435                 last LINE if $pm eq '__END__';
 436
 437                 if ($pm eq '__POD__') {
 438                     while (<FH>) { last if (/^=cut/) }
 439                     next LINE;
 440                 }
 441
 442                 $pm = 'CGI/Apache.pm' if /^Apache(?:\.pm)$/;
 443
 444                 add_deps(
 445                     used_by => $key,
 446                     rv      => $rv,
 447                     modules => [$pm],
 448                     skip    => $skip
 449                 );
 450
 451                 my $preload = $Preload{$pm} or next;
 452                 if ($preload eq 'sub') {
 453                     $pm =~ s/\.p[mh]$//i;
 454                     $preload = [ _glob_in_inc($pm, 1) ];
 455                 }
 456                 elsif (UNIVERSAL::isa($preload, 'CODE')) {
 457                     $preload = [ $preload->($pm) ];
 458                 }
 459
 460                 add_deps(
 461                     used_by => $key,
 462                     rv      => $rv,
 463                     modules => $preload,
 464                     skip    => $skip
 465                 );
 466             }
 467         }
 468         close FH;
 469
 470         # }}}
 471     }
 472
 473     # Top-level recursion handling {{{
 474     while ($recurse) {
 475         my $count = keys %$rv;
 476         my @files = sort grep -T $_->{file}, values %$rv;
 477         scan_deps_static({
 478             files   => [ map $_->{file}, @files ],
 479             keys    => [ map $_->{key},  @files ],
 480             rv      => $rv,
 481             skip    => $skip,
 482             recurse => 0,
 483         }) or ($args->{_deep} and return);
 484         last if $count == keys %$rv;
 485     }
 486
 487     # }}}
 488
 489     return $rv;
 490 }
 491
 492 sub scan_deps_runtime {
 493     my %args = (
 494         perl => $^X,
 495         rv   => {},
 496         (@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
 497     );
 498     my ($files, $rv, $execute, $compile, $skip, $perl) =
 499       @args{qw( files rv execute compile skip perl )};
 500
 501     $files = (ref($files)) ? $files : [$files];
 502
 503     my ($inchash, $incarray, $dl_shared_objects) = ({}, [], []);
 504     if ($compile) {
 505         my $file;
 506
 507         foreach $file (@$files) {
 508             ($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
 509             _compile($perl, $file, $inchash, $dl_shared_objects, $incarray);
 510
 511             my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
 512             _merge_rv($rv_sub, $rv);
 513         }
 514     }
 515     elsif ($execute) {
 516         my $excarray = (ref($execute)) ? $execute : [@$files];
 517         my $exc;
 518         my $first_flag = 1;
 519         foreach $exc (@$excarray) {
 520             ($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
 521             _execute(
 522                 $perl, $exc, $inchash, $dl_shared_objects, $incarray,
 523                 $first_flag
 524             );
 525             $first_flag = 0;
 526         }
 527
 528         my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
 529         _merge_rv($rv_sub, $rv);
 530     }
 531
 532     return ($rv);
 533 }
 534
 535 sub scan_line {
 536     my $line = shift;
 537     my %found;
 538
 539     return '__END__' if $line =~ /^__(?:END|DATA)__$/;
 540     return '__POD__' if $line =~ /^=\w/;
 541
 542     $line =~ s/\s*#.*$//;
 543     $line =~ s/[\\\/]+/\//g;
 544
 545     foreach (split(/;/, $line)) {
 546         if (/^\s*package\s+(\w+)/) {
 547             $CurrentPackage = $1;
 548             $CurrentPackage =~ s{::}{/}g;
 549             return;
 550         }
 551         return if /^\s*(use|require)\s+[\d\._]+/;
 552         if (my ($autouse) = /^\s*use\s+autouse\s+(["'].*?["']|\w+)/)
 553         {
 554             $autouse =~ s/["']//g;
 555             $autouse =~ s{::}{/}g;
 556             return ("autouse.pm", "$autouse.pm");
 557         }
 558
 559         if (my ($libs) = /\b(?:use\s+lib\s+|(?:unshift|push)\W+\@INC\W+)(.+)/)
 560         {
 561             my $archname =
 562               defined($Config{archname}) ? $Config{archname} : '';
 563             my $ver = defined($Config{version}) ? $Config{version} : '';
 564             foreach (grep(/\w/, split(/["';() ]/, $libs))) {
 565                 unshift(@INC, "$_/$ver")           if -d "$_/$ver";
 566                 unshift(@INC, "$_/$archname")      if -d "$_/$archname";
 567                 unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname";
 568             }
 569             next;
 570         }
 571
 572         $found{$_}++ for scan_chunk($_);
 573     }
 574
 575     return sort keys %found;
 576 }
 577
 578 sub scan_chunk {
 579     my $chunk = shift;
 580
 581     # Module name extraction heuristics {{{
 582     my $module = eval {
 583         $_ = $chunk;
 584
 585         return [ 'base.pm',
 586             map { s{::}{/}g; "$_.pm" }
 587               grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 588           if /^\s* use \s+ base \s+ (.*)/sx;
 589
 590         return [ 'Class/Autouse.pm',
 591             map { s{::}{/}g; "$_.pm" }
 592               grep { length and !/^:|^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 593           if /^\s* use \s+ Class::Autouse \s+ (.*)/sx
 594               or /^\s* Class::Autouse \s* -> \s* autouse \s* (.*)/sx;
 595
 596         return [ 'POE.pm',
 597             map { s{::}{/}g; "POE/$_.pm" }
 598               grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 599           if /^\s* use \s+ POE \s+ (.*)/sx;
 600
 601         return [ 'encoding.pm',
 602             map { _find_encoding($_) }
 603               grep { length and !/^q[qw]?$/ } split(/[^\w:-]+/, $1) ]
 604           if /^\s* use \s+ encoding \s+ (.*)/sx;
 605
 606         return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']+)/;
 607         return $1
 608           if /(?:^|\s)(?:use|no|require)\s+\(\s*([\w:\.\-\\\/\"\']+)\s*\)/;
 609
 610         if (   s/(?:^|\s)eval\s+\"([^\"]+)\"/$1/
 611             or s/(?:^|\s)eval\s*\(\s*\"([^\"]+)\"\s*\)/$1/)
 612         {
 613             return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']*)/;
 614         }
 615
 616         return "File/Glob.pm" if /<[^>]*[^\$\w>][^>]*>/;
 617         return "DBD/$1.pm"    if /\b[Dd][Bb][Ii]:(\w+):/;
 618         if (/(?:(:encoding)|\b(?:en|de)code)\(\s*['"]?([-\w]+)/) {
 619             my $mod = _find_encoding($2);
 620             return [ 'PerlIO.pm', $mod ] if $1 and $mod;
 621             return $mod if $mod;
 622         }
 623         return $1 if /(?:^|\s)(?:do|require)\s+[^"]*"(.*?)"/;
 624         return $1 if /(?:^|\s)(?:do|require)\s+[^']*'(.*?)'/;
 625         return $1 if /[^\$]\b([\w:]+)->\w/ and $1 ne 'Tk';
 626         return $1 if /\b(\w[\w:]*)::\w+\(/;
 627
 628         if ($SeenTk) {
 629             my @modules;
 630             while (/->\s*([A-Z]\w+)/g) {
 631                 push @modules, "Tk/$1.pm";
 632             }
 633             while (/->\s*Scrolled\W+([A-Z]\w+)/g) {
 634                 push @modules, "Tk/$1.pm";
 635                 push @modules, "Tk/Scrollbar.pm";
 636             }
 637             return \@modules;
 638         }
 639         return;
 640     };
 641
 642     # }}}
 643
 644     return unless defined($module);
 645     return wantarray ? @$module : $module->[0] if ref($module);
 646
 647     $module =~ s/^['"]//;
 648     return unless $module =~ /^\w/;
 649
 650     $module =~ s/\W+$//;
 651     $module =~ s/::/\//g;
 652     return if $module =~ /^(?:[\d\._]+|'.*[^']|".*[^"])$/;
 653
 654     $module .= ".pm" unless $module =~ /\./;
 655     return $module;
 656 }
 657
 658 sub _find_encoding {
 659     return unless $] >= 5.008 and eval { require Encode; %Encode::ExtModule };
 660
 661     my $mod = $Encode::ExtModule{ Encode::find_encoding($_[0])->name }
 662       or return;
 663     $mod =~ s{::}{/}g;
 664     return "$mod.pm";
 665 }
 666
 667 sub _add_info {
 668     my ($rv, $module, $file, $used_by, $type) = @_;
 669     return unless defined($module) and defined($file);
 670
 671     $rv->{$module} ||= {
 672         file => $file,
 673         key  => $module,
 674         type => $type,
 675     };
 676
 677     push @{ $rv->{$module}{used_by} }, $used_by
 678       if defined($used_by)
 679       and $used_by ne $module
 680       and !grep { $_ eq $used_by } @{ $rv->{$module}{used_by} };
 681 }
 682
 683 sub add_deps {
 684     my %args =
 685       ((@_ and $_[0] =~ /^(?:modules|rv|used_by)$/)
 686         ? @_
 687         : (rv => (ref($_[0]) ? shift(@_) : undef), modules => [@_]));
 688
 689     my $rv   = $args{rv}   || {};
 690     my $skip = $args{skip} || {};
 691     my $used_by = $args{used_by};
 692
 693     foreach my $module (@{ $args{modules} }) {
 694         if (exists $rv->{$module}) {
 695             _add_info($rv, undef, undef, $used_by, undef);
 696             next;
 697         }
 698
 699         my $file = _find_in_inc($module) or next;
 700         next if $skip->{$file};
 701         next if is_insensitive_fs() and $skip->{lc($file)};
 702
 703         my $type = 'module';
 704         $type = 'data' unless $file =~ /\.p[mh]$/i;
 705         _add_info($rv, $module, $file, $used_by, $type);
 706
 707         if ($module =~ /(.*?([^\/]*))\.p[mh]$/i) {
 708             my ($path, $basename) = ($1, $2);
 709
 710             foreach (_glob_in_inc("auto/$path")) {
 711                 next if $skip->{$_->{file}};
 712                 next if is_insensitive_fs() and $skip->{lc($_->{file})};
 713                 next if $_->{file} =~ m{\bauto/$path/.*/};  # weed out subdirs
 714                 next if $_->{name} =~ m/(?:^|\/)\.(?:exists|packlist)$/;
 715                 my $ext = lc($1) if $_->{name} =~ /(\.[^.]+)$/;
 716                 next if $ext eq lc(lib_ext());
 717                 my $type = 'shared' if $ext eq lc(dl_ext());
 718                 $type = 'autoload' if $ext eq '.ix' or $ext eq '.al';
 719                 $type ||= 'data';
 720
 721                 _add_info($rv, "auto/$path/$_->{name}", $_->{file}, $module,
 722                     $type);
 723             }
 724         }
 725     }
 726
 727     return $rv;
 728 }
 729
 730 sub _find_in_inc {
 731     my $file = shift;
 732
 733     # absolute file names
 734     return $file if -f $file;
 735
 736     foreach my $dir (grep !/\bBSDPAN\b/, @INC) {
 737         return "$dir/$file" if -f "$dir/$file";
 738     }
 739     return;
 740 }
 741
 742 sub _glob_in_inc {
 743     my $subdir  = shift;
 744     my $pm_only = shift;
 745     my @files;
 746
 747     require File::Find;
 748
 749     $subdir =~ s/\$CurrentPackage/$CurrentPackage/;
 750
 751     foreach my $dir (map "$_/$subdir", grep !/\bBSDPAN\b/, @INC) {
 752         next unless -d $dir;
 753         File::Find::find(
 754             sub {
 755                 my $name = $File::Find::name;
 756                 $name =~ s!^\Q$dir\E/!!;
 757                 return if $pm_only and lc($name) !~ /\.p[mh]$/i;
 758                 push @files, $pm_only
 759                   ? "$subdir/$name"
 760                   : {             file => $File::Find::name,
 761                     name => $name,
 762                   }
 763                   if -f;
 764             },
 765             $dir
 766         );
 767     }
 768
 769     return @files;
 770 }
 771
 772 # App::Packer compatibility functions
 773
 774 sub new {
 775     my ($class, $self) = @_;
 776     return bless($self ||= {}, $class);
 777 }
 778
 779 sub set_file {
 780     my $self = shift;
 781     foreach my $script (@_) {
 782         my $basename = $script;
 783         $basename =~ s/.*\///;
 784         $self->{main} = {
 785             key  => $basename,
 786             file => $script,
 787         };
 788     }
 789 }
 790
 791 sub set_options {
 792     my $self = shift;
 793     my %args = @_;
 794     foreach my $module (@{ $args{add_modules} }) {
 795         $module =~ s/::/\//g;
 796         $module .= '.pm' unless $module =~ /\.p[mh]$/i;
 797         my $file = _find_in_inc($module) or next;
 798         $self->{files}{$module} = $file;
 799     }
 800 }
 801
 802 sub calculate_info {
 803     my $self = shift;
 804     my $rv   = scan_deps(
 805         keys  => [ $self->{main}{key}, sort keys %{ $self->{files} }, ],
 806         files => [ $self->{main}{file},
 807             map { $self->{files}{$_} } sort keys %{ $self->{files} },
 808         ],
 809         recurse => 1,
 810     );
 811
 812     my $info = {
 813         main => {  file     => $self->{main}{file},
 814             store_as => $self->{main}{key},
 815         },
 816     };
 817
 818     my %cache = ($self->{main}{key} => $info->{main});
 819     foreach my $key (sort keys %{ $self->{files} }) {
 820         my $file = $self->{files}{$key};
 821
 822         $cache{$key} = $info->{modules}{$key} = {
 823             file     => $file,
 824             store_as => $key,
 825             used_by  => [ $self->{main}{key} ],
 826         };
 827     }
 828
 829     foreach my $key (sort keys %{$rv}) {
 830         my $val = $rv->{$key};
 831         if ($cache{ $val->{key} }) {
 832             push @{ $info->{ $val->{type} }->{ $val->{key} }->{used_by} },
 833               @{ $val->{used_by} };
 834         }
 835         else {
 836             $cache{ $val->{key} } = $info->{ $val->{type} }->{ $val->{key} } =
 837               {        file     => $val->{file},
 838                 store_as => $val->{key},
 839                 used_by  => $val->{used_by},
 840               };
 841         }
 842     }
 843
 844     $self->{info} = { main => $info->{main} };
 845
 846     foreach my $type (sort keys %{$info}) {
 847         next if $type eq 'main';
 848
 849         my @val;
 850         if (UNIVERSAL::isa($info->{$type}, 'HASH')) {
 851             foreach my $val (sort values %{ $info->{$type} }) {
 852                 @{ $val->{used_by} } = map $cache{$_} || "!!$_!!",
 853                   @{ $val->{used_by} };
 854                 push @val, $val;
 855             }
 856         }
 857
 858         $type = 'modules' if $type eq 'module';
 859         $self->{info}{$type} = \@val;
 860     }
 861 }
 862
 863 sub get_files {
 864     my $self = shift;
 865     return $self->{info};
 866 }
 867
 868 # scan_deps_runtime utility functions
 869
 870 sub _compile {
 871     my ($perl, $file, $inchash, $dl_shared_objects, $incarray) = @_;
 872
 873     my ($fhout, $fname) = File::Temp::tempfile("XXXXXX");
 874     my $fhin  = FileHandle->new($file) or die "Couldn't open $file\n";
 875
 876     my $line = do { local $/; <$fhin> };
 877     $line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
 878     $line =~ s/^(.*?)((?:[\r\n]+__(?:DATA|END)__[\r\n]+)|$)/
 879 use Module::ScanDeps::DataFeed '$fname.out';
 880 sub {
 881 $1
 882 }
 883 $2/s;
 884     $fhout->print($line);
 885     $fhout->close;
 886     $fhin->close;
 887
 888     system($perl, $fname);
 889
 890     _extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
 891     unlink("$fname");
 892     unlink("$fname.out");
 893 }
 894
 895 sub _execute {
 896     my ($perl, $file, $inchash, $dl_shared_objects, $incarray, $firstflag) = @_;
 897
 898     $DB::single = $DB::single = 1;
 899     my ($fhout, $fname) = File::Temp::tempfile("XXXXXX");
 900     $fname = _abs_path($fname);
 901     my $fhin  = FileHandle->new($file) or die "Couldn't open $file";
 902
 903     my $line = do { local $/; <$fhin> };
 904     $line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
 905     $line = "use Module::ScanDeps::DataFeed '$fname.out';\n" . $line;
 906     $fhout->print($line);
 907     $fhout->close;
 908     $fhin->close;
 909
 910     File::Path::rmtree( ['_Inline'], 0, 1); # XXX hack
 911     system($perl, $fname) == 0 or die "SYSTEM ERROR in executing $file: $?";
 912
 913     _extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
 914     unlink("$fname");
 915     unlink("$fname.out");
 916 }
 917
 918 sub _make_rv {
 919     my ($inchash, $dl_shared_objects, $inc_array) = @_;
 920
 921     my $rv = {};
 922     my @newinc = map(quotemeta($_), @$inc_array);
 923     my $inc = join('|', sort { length($b) <=> length($a) } @newinc);
 924
 925     require File::Spec;
 926
 927     my $key;
 928     foreach $key (keys(%$inchash)) {
 929         my $newkey = $key;
 930         $newkey =~ s"^(?:(?:$inc)/?)""sg if File::Spec->file_name_is_absolute($newkey);
 931
 932         $rv->{$newkey} = {
 933             'used_by' => [],
 934             'file'    => $inchash->{$key},
 935             'type'    => _gettype($inchash->{$key}),
 936             'key'     => $key
 937         };
 938     }
 939
 940     my $dl_file;
 941     foreach $dl_file (@$dl_shared_objects) {
 942         my $key = $dl_file;
 943         $key =~ s"^(?:(?:$inc)/?)""s;
 944
 945         $rv->{$key} = {
 946             'used_by' => [],
 947             'file'    => $dl_file,
 948             'type'    => 'shared',
 949             'key'     => $key
 950         };
 951     }
 952
 953     return $rv;
 954 }
 955
 956 sub _extract_info {
 957     my ($fname, $inchash, $dl_shared_objects, $incarray) = @_;
 958
 959     use vars qw(%inchash @dl_shared_objects @incarray);
 960     my $fh = FileHandle->new($fname) or die "Couldn't open $fname";
 961     my $line = do { local $/; <$fh> };
 962     $fh->close;
 963
 964     eval $line;
 965
 966     $inchash->{$_} = $inchash{$_} for keys %inchash;
 967     @$dl_shared_objects = @dl_shared_objects;
 968     @$incarray          = @incarray;
 969 }
 970
 971 sub _gettype {
 972     my $name = shift;
 973     my $dlext = quotemeta(dl_ext());
 974
 975     return 'autoload' if $name =~ /(?:\.ix|\.al|\.bs)$/i;
 976     return 'module'   if $name =~ /\.p[mh]$/i;
 977     return 'shared'   if $name =~ /\.$dlext$/i;
 978     return 'data';
 979 }
 980
 981 sub _merge_rv {
 982     my ($rv_sub, $rv) = @_;
 983
 984     my $key;
 985     foreach $key (keys(%$rv_sub)) {
 986         my %mark;
 987         if ($rv->{$key} and _not_dup($key, $rv, $rv_sub)) {
 988             warn "Different modules for file '$key' were found.\n"
 989                 . " -> Using '" . _abs_path($rv_sub->{$key}{file}) . "'.\n"
 990                 . " -> Ignoring '" . _abs_path($rv->{$key}{file}) . "'.\n";
 991             $rv->{$key}{used_by} = [
 992                 grep (!$mark{$_}++,
 993                     @{ $rv->{$key}{used_by} },
 994                     @{ $rv_sub->{$key}{used_by} })
 995             ];
 996             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
 997             $rv->{$key}{file} = $rv_sub->{$key}{file};
 998         }
 999         elsif ($rv->{$key}) {
1000             $rv->{$key}{used_by} = [
1001                 grep (!$mark{$_}++,
1002                     @{ $rv->{$key}{used_by} },
1003                     @{ $rv_sub->{$key}{used_by} })
1004             ];
1005             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
1006         }
1007         else {
1008             $rv->{$key} = {
1009                 used_by => [ @{ $rv_sub->{$key}{used_by} } ],
1010                 file    => $rv_sub->{$key}{file},
1011                 key     => $rv_sub->{$key}{key},
1012                 type    => $rv_sub->{$key}{type}
1013             };
1014
1015             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
1016         }
1017     }
1018 }
1019
1020 sub _not_dup {
1021     my ($key, $rv1, $rv2) = @_;
1022     (_abs_path($rv1->{$key}{file}) ne _abs_path($rv2->{$key}{file}));
1023 }
1024
1025 sub _abs_path {
1026     return join(
1027         '/',
1028         Cwd::abs_path(File::Basename::dirname($_[0])),
1029         File::Basename::basename($_[0]),
1030     );
1031 }
1032
1033 1;
1034
1035 __END__
1036
1037 =head1 SEE ALSO
1038
1039 L<scandeps.pl> is a bundled utility that writes C<PREREQ_PM> section
1040 for a number of files.
1041
1042 An application of B<Module::ScanDeps> is to generate executables from
1043 scripts that contains prerequisite modules; this module supports two
1044 such projects, L<PAR> and L<App::Packer>.  Please see their respective
1045 documentations on CPAN for further information.
1046
1047 =head1 AUTHORS
1048
1049 Audrey Tang E<lt>autrijus@autrijus.orgE<gt>
1050
1051 Parts of heuristics were deduced from:
1052
1053 =over 4
1054
1055 =item *
1056
1057 B<PerlApp> by ActiveState Tools Corp L<http://www.activestate.com/>
1058
1059 =item *
1060
1061 B<Perl2Exe> by IndigoStar, Inc L<http://www.indigostar.com/>
1062
1063 =back
1064
1065 The B<scan_deps_runtime> function is contributed by Edward S. Peschko.
1066
1067 L<http://par.perl.org/> is the official website for this module.  You
1068 can write to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty
1069 mail to E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
1070
1071 Please submit bug reports to E<lt>bug-Module-ScanDeps@rt.cpan.orgE<gt>.
1072
1073 =head1 COPYRIGHT
1074
1075 Copyright 2002, 2003, 2004, 2005, 2006 by
1076 Audrey Tang E<lt>autrijus@autrijus.orgE<gt>.
1077
1078 This program is free software; you can redistribute it and/or modify it
1079 under the same terms as Perl itself.
1080
1081 See L<http://www.perl.com/perl/misc/Artistic.html>
1082
1083 =cut