local-lib5/lib/perl5/Module/ScanDeps.pm

   1 package Module::ScanDeps;
   2 use 5.006;
   3 use strict;
   4 use warnings;
   5 use vars qw( $VERSION @EXPORT @EXPORT_OK @ISA $CurrentPackage @IncludeLibs $ScanFileRE );
   6
   7 $VERSION   = '0.96';
   8 @EXPORT    = qw( scan_deps scan_deps_runtime );
   9 @EXPORT_OK = qw( scan_line scan_chunk add_deps scan_deps_runtime path_to_inc_name );
  10
  11 use Config;
  12 require Exporter;
  13 our @ISA = qw(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 version;
  23 use Cwd ();
  24 use File::Path ();
  25 use File::Temp ();
  26 use File::Spec ();
  27 use File::Basename ();
  28 use FileHandle;
  29 use Module::Build::ModuleInfo;
  30
  31 $ScanFileRE = qr/(?:^|\\|\/)(?:[^.]*|.*\.(?i:p[ml]|t|al))$/;
  32
  33 =head1 NAME
  34
  35 Module::ScanDeps - Recursively scan Perl code for dependencies
  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         uses    => [ 'Test/Other.pm', ... ],
  79     }
  80
  81 One function, C<scan_deps>, is exported by default.  Other
  82 functions such as (C<scan_line>, C<scan_chunk>, C<add_deps>, C<path_to_inc_name>)
  83 are exported upon request.
  84
  85 Users of B<App::Packer> may also use this module as the dependency-checking
  86 frontend, by tweaking their F<p2e.pl> like below:
  87
  88     use Module::ScanDeps;
  89     ...
  90     my $packer = App::Packer->new( frontend => 'Module::ScanDeps' );
  91     ...
  92
  93 Please see L<App::Packer::Frontend> for detailed explanation on
  94 the structure returned by C<get_files>.
  95
  96 =head2 B<scan_deps>
  97
  98     $rv_ref = scan_deps(
  99         files      => \@files,     recurse => $recurse,
 100         rv         => \%rv,        skip    => \%skip,
 101         compile    => $compile,    execute => $execute,
 102     );
 103     $rv_ref = scan_deps(@files); # shorthand, with recurse => 1
 104
 105 This function scans each file in C<@files>, registering their
 106 dependencies into C<%rv>, and returns a reference to the updated
 107 C<%rv>.  The meaning of keys and values are explained above.
 108
 109 If C<$recurse> is true, C<scan_deps> will call itself recursively,
 110 to perform a breadth-first search on text files (as defined by the
 111 -T operator) found in C<%rv>.
 112
 113 If the C<\%skip> is specified, files that exists as its keys are
 114 skipped.  This is used internally to avoid infinite recursion.
 115
 116 If C<$compile> or C<$execute> is true, runs C<files> in either
 117 compile-only or normal mode, then inspects their C<%INC> after
 118 termination to determine additional runtime dependencies.
 119
 120 If C<$execute> is an array reference, runs the files contained
 121 in it instead of C<@files>.
 122
 123 If performance of the scanning process is a concern, C<cache_file> can be
 124 set to a filename. The scanning results will be cached and written to the
 125 file. This will speed up the scanning process on subsequent runs.
 126
 127 Additionally, an option C<warn_missing> is recognized. If set to true,
 128 C<scan_deps> issues a warning to STDERR for every module file that the
 129 scanned code depends but that wasn't found. Please note that this may
 130 also report numerous false positives. That is why by default, the heuristic
 131 silently drops all dependencies it cannot find.
 132
 133 =head2 B<scan_deps_runtime>
 134
 135 Like B<scan_deps>, but skips the static scanning part.
 136
 137 =head2 B<scan_line>
 138
 139     @modules = scan_line($line);
 140
 141 Splits a line into chunks (currently with the semicolon characters), and
 142 return the union of C<scan_chunk> calls of them.
 143
 144 If the line is C<__END__> or C<__DATA__>, a single C<__END__> element is
 145 returned to signify the end of the program.
 146
 147 Similarly, it returns a single C<__POD__> if the line matches C</^=\w/>;
 148 the caller is responsible for skipping appropriate number of lines
 149 until C<=cut>, before calling C<scan_line> again.
 150
 151 =head2 B<scan_chunk>
 152
 153     $module = scan_chunk($chunk);
 154     @modules = scan_chunk($chunk);
 155
 156 Apply various heuristics to C<$chunk> to find and return the module
 157 name(s) it contains.  In scalar context, returns only the first module
 158 or C<undef>.
 159
 160 =head2 B<add_deps>
 161
 162     $rv_ref = add_deps( rv => \%rv, modules => \@modules );
 163     $rv_ref = add_deps( @modules ); # shorthand, without rv
 164
 165 Resolves a list of module names to its actual on-disk location, by
 166 finding in C<@INC> and C<@Module::ScanDeps::IncludeLibs>;
 167 modules that cannot be found are skipped.
 168
 169 This function populates the C<%rv> hash with module/filename pairs, and
 170 returns a reference to it.
 171
 172 =head2 B<path_to_inc_name>
 173
 174     $perl_name = path_to_inc_name($path, $warn)
 175
 176 Assumes C<$path> refers to a perl file and does it's best to return the
 177 name as it would appear in %INC. Returns undef if no match was found
 178 and a prints a warning to STDERR if C<$warn> is true.
 179
 180 E.g. if C<$path> = perl/site/lib/Module/ScanDeps.pm then C<$perl_name>
 181 will be Module/ScanDeps.pm.
 182
 183 =head1 NOTES
 184
 185 =head2 B<@Module::ScanDeps::IncludeLibs>
 186
 187 You can set this global variable to specify additional directories in
 188 which to search modules without modifying C<@INC> itself.
 189
 190 =head2 B<$Module::ScanDeps::ScanFileRE>
 191
 192 You can set this global variable to specify a regular expression to
 193 identify what files to scan. By default it includes all files of
 194 the following types: .pm, .pl, .t and .al. Additionally, all files
 195 without a suffix are considered.
 196
 197 For instance, if you want to scan all files then use the following:
 198
 199 C<$Module::ScanDeps::ScanFileRE = qr/./>
 200
 201 =head1 CAVEATS
 202
 203 This module intentially ignores the B<BSDPAN> hack on FreeBSD -- the
 204 additional directory is removed from C<@INC> altogether.
 205
 206 The static-scanning heuristic is not likely to be 100% accurate, especially
 207 on modules that dynamically load other modules.
 208
 209 Chunks that span multiple lines are not handled correctly.  For example,
 210 this one works:
 211
 212     use base 'Foo::Bar';
 213
 214 But this one does not:
 215
 216     use base
 217         'Foo::Bar';
 218
 219 =cut
 220
 221 my $SeenTk;
 222
 223 # Pre-loaded module dependencies {{{
 224 my %Preload;
 225 %Preload = (
 226     'AnyDBM_File.pm'  => [qw( SDBM_File.pm )],
 227     'Authen/SASL.pm'  => 'sub',
 228     'Bio/AlignIO.pm'  => 'sub',
 229     'Bio/Assembly/IO.pm'  => 'sub',
 230     'Bio/Biblio/IO.pm'  => 'sub',
 231     'Bio/ClusterIO.pm'  => 'sub',
 232     'Bio/CodonUsage/IO.pm'  => 'sub',
 233     'Bio/DB/Biblio.pm'  => 'sub',
 234     'Bio/DB/Flat.pm'  => 'sub',
 235     'Bio/DB/GFF.pm'  => 'sub',
 236     'Bio/DB/Taxonomy.pm'  => 'sub',
 237     'Bio/Graphics/Glyph.pm'  => 'sub',
 238     'Bio/MapIO.pm'  => 'sub',
 239     'Bio/Matrix/IO.pm'  => 'sub',
 240     'Bio/Matrix/PSM/IO.pm'  => 'sub',
 241     'Bio/OntologyIO.pm'  => 'sub',
 242     'Bio/PopGen/IO.pm'  => 'sub',
 243     'Bio/Restriction/IO.pm'  => 'sub',
 244     'Bio/Root/IO.pm'  => 'sub',
 245     'Bio/SearchIO.pm'  => 'sub',
 246     'Bio/SeqIO.pm'  => 'sub',
 247     'Bio/Structure/IO.pm'  => 'sub',
 248     'Bio/TreeIO.pm'  => 'sub',
 249     'Bio/LiveSeq/IO.pm'  => 'sub',
 250     'Bio/Variation/IO.pm'  => 'sub',
 251     'Catalyst.pm' => sub {
 252         return ('Catalyst/Runtime.pm',
 253                 'Catalyst/Dispatcher.pm',
 254                 _glob_in_inc('Catalyst/DispatchType', 1));
 255     },
 256     'Catalyst/Engine.pm' => 'sub',
 257     'Class/MakeMethods.pm' => 'sub',
 258     'Class/MethodMaker.pm' => 'sub',
 259     'Config/Any.pm' =>'sub',
 260     'Crypt/Random.pm' => sub {
 261         _glob_in_inc('Crypt/Random/Provider', 1);
 262     },
 263     'Crypt/Random/Generator.pm' => sub {
 264         _glob_in_inc('Crypt/Random/Provider', 1);
 265     },
 266     'DateTime/Locale.pm' => 'sub',
 267     'DBI.pm' => sub {
 268         grep !/\bProxy\b/, _glob_in_inc('DBD', 1);
 269     },
 270     'DBIx/Class.pm' => 'sub',
 271     'DBIx/SearchBuilder.pm' => 'sub',
 272     'DBIx/ReportBuilder.pm' => 'sub',
 273     'Device/ParallelPort.pm' => 'sub',
 274     'Device/SerialPort.pm' => [ qw(
 275         termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
 276     ) ],
 277     'Email/Send.pm' => 'sub',
 278     'Event.pm' => [ map {"Event/$_.pm" } qw(idle io signal timer var)],
 279     'ExtUtils/MakeMaker.pm' => sub {
 280         grep /\bMM_/, _glob_in_inc('ExtUtils', 1);
 281     },
 282     'File/Basename.pm' => [qw( re.pm )],
 283     'File/HomeDir.pm' => 'sub',
 284     'File/Spec.pm'     => sub {
 285         require File::Spec;
 286         map { my $name = $_; $name =~ s!::!/!g; "$name.pm" } @File::Spec::ISA;
 287     },
 288     'HTTP/Message.pm' => [ qw(
 289         URI/URL.pm          URI.pm
 290     ) ],
 291     'Image/ExifTool.pm' => sub {
 292         return( _glob_in_inc("Image/ExifTool", 1), qw(
 293             File/RandomAccess.pm
 294         ));
 295     },
 296     'Image/Info.pm' => sub {
 297         return( _glob_in_inc("Image/Info", 1), qw(
 298             Image/TIFF.pm
 299         ));
 300     },
 301     'IO.pm' => [ qw(
 302         IO/Handle.pm        IO/Seekable.pm      IO/File.pm
 303         IO/Pipe.pm          IO/Socket.pm        IO/Dir.pm
 304     ) ],
 305     'IO/Socket.pm'     => [qw( IO/Socket/UNIX.pm )],
 306     'Log/Log4perl.pm' => 'sub',
 307     'Log/Any.pm' => 'sub',
 308     'LWP/UserAgent.pm' => sub {
 309         return(
 310             qw(
 311             URI/URL.pm          URI/http.pm         LWP/Protocol/http.pm
 312             ),
 313             _glob_in_inc("LWP/Authen", 1),
 314             _glob_in_inc("LWP/Protocol", 1),
 315         );
 316     },
 317     'LWP/Parallel.pm' => sub {
 318         _glob_in_inc( 'LWP/Parallel', 1 ),
 319         qw(
 320             LWP/ParallelUA.pm       LWP/UserAgent.pm
 321             LWP/RobotPUA.pm         LWP/RobotUA.pm
 322         ),
 323     },
 324     'LWP/Parallel/UserAgent.pm' => sub {
 325         qw( LWP/Parallel.pm ),
 326         @{ _get_preload('LWP/Parallel.pm') }
 327     },
 328     'Locale/Maketext/Lexicon.pm'    => 'sub',
 329     'Locale/Maketext/GutsLoader.pm' => [qw( Locale/Maketext/Guts.pm )],
 330     'Mail/Audit.pm'                => 'sub',
 331     'Math/BigInt.pm'                => 'sub',
 332     'Math/BigFloat.pm'              => 'sub',
 333     'Math/Symbolic.pm'              => 'sub',
 334     'Module/Build.pm'               => 'sub',
 335     'Module/Pluggable.pm'           => sub {
 336         _glob_in_inc('$CurrentPackage/Plugin', 1);
 337     },
 338     'MIME/Decoder.pm'               => 'sub',
 339     'Net/DNS/RR.pm'                 => 'sub',
 340     'Net/FTP.pm'                    => 'sub',
 341     'Net/Server.pm'                 => 'sub',
 342     'Net/SSH/Perl.pm'               => 'sub',
 343     'PAR/Repository.pm'             => 'sub',
 344     'PAR/Repository/Client.pm'      => 'sub',
 345     'Perl/Critic.pm'                => 'sub', #not only Perl/Critic/Policy
 346     'PDF/API2/Resource/Font.pm'     => 'sub',
 347     'PDF/API2/Basic/TTF/Font.pm'    => sub {
 348         _glob_in_inc('PDF/API2/Basic/TTF', 1);
 349     },
 350     'PDF/Writer.pm'                 => 'sub',
 351     'POE.pm'                           => [ qw(
 352         POE/Kernel.pm POE/Session.pm
 353     ) ],
 354     'POE/Kernel.pm'                    => sub {
 355         _glob_in_inc('POE/XS/Resource', 1),
 356         _glob_in_inc('POE/Resource', 1),
 357         _glob_in_inc('POE/XS/Loop', 1),
 358         _glob_in_inc('POE/Loop', 1),
 359     },
 360     'PPI.pm'                        => 'sub',
 361     'Parse/AFP.pm'                  => 'sub',
 362     'Parse/Binary.pm'               => 'sub',
 363     'PerlIO.pm'                     => [ 'PerlIO/scalar.pm' ],
 364     'Regexp/Common.pm'              => 'sub',
 365     'SerialJunk.pm' => [ qw(
 366         termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
 367     ) ],
 368     'SOAP/Lite.pm'                  => sub {
 369         (($] >= 5.008 ? ('utf8.pm') : ()), _glob_in_inc('SOAP/Transport', 1));
 370     },
 371     'SQL/Parser.pm' => sub {
 372         _glob_in_inc('SQL/Dialects', 1);
 373     },
 374     'SQL/Translator/Schema.pm' => sub {
 375         _glob_in_inc('SQL/Translator', 1);
 376     },
 377     'SVK/Command.pm' => sub {
 378         _glob_in_inc('SVK', 1);
 379     },
 380     'SVN/Core.pm' => sub {
 381         _glob_in_inc('SVN', 1),
 382         map "auto/SVN/$_->{name}", _glob_in_inc('auto/SVN'),
 383     },
 384     'Template.pm'      => 'sub',
 385     'Term/ReadLine.pm' => 'sub',
 386     'Test/Deep.pm'     => 'sub',
 387     'Tk.pm'            => sub {
 388         $SeenTk = 1;
 389         qw( Tk/FileSelect.pm Encode/Unicode.pm );
 390     },
 391     'Tk/Balloon.pm'     => [qw( Tk/balArrow.xbm )],
 392     'Tk/BrowseEntry.pm' => [qw( Tk/cbxarrow.xbm Tk/arrowdownwin.xbm )],
 393     'Tk/ColorEditor.pm' => [qw( Tk/ColorEdit.xpm )],
 394     'Tk/DragDrop/Common.pm' => sub {
 395         _glob_in_inc('Tk/DragDrop', 1),
 396     },
 397     'Tk/FBox.pm'        => [qw( Tk/folder.xpm Tk/file.xpm )],
 398     'Tk/Getopt.pm'      => [qw( Tk/openfolder.xpm Tk/win.xbm )],
 399     'Tk/Toplevel.pm'    => [qw( Tk/Wm.pm )],
 400     'URI.pm'            => sub {
 401         grep !/.\b[_A-Z]/, _glob_in_inc('URI', 1);
 402     },
 403     'Win32/EventLog.pm'    => [qw( Win32/IPC.pm )],
 404     'Win32/Exe.pm'         => 'sub',
 405     'Win32/TieRegistry.pm' => [qw( Win32API/Registry.pm )],
 406     'Win32/SystemInfo.pm'  => [qw( Win32/cpuspd.dll )],
 407     'Wx.pm'  => [qw( attributes.pm Alien/wxWidgets/msw_2_8_10_uni_gcc_3_4/lib/wxbase28u_gcc_custom.dll)], #still cannot find this .dll
 408     'XML/Parser.pm'        => sub {
 409         _glob_in_inc('XML/Parser/Style', 1),
 410         _glob_in_inc('XML/Parser/Encodings', 1),
 411     },
 412     'XML/Parser/Expat.pm' => sub {
 413         ($] >= 5.008) ? ('utf8.pm') : ();
 414     },
 415     'XML/SAX.pm' => [qw( XML/SAX/ParserDetails.ini ) ],
 416     'XMLRPC/Lite.pm' => sub {
 417         _glob_in_inc('XMLRPC/Transport', 1),;
 418     },
 419     'YAML.pm' => [qw( YAML/Loader.pm YAML/Dumper.pm )],
 420     'diagnostics.pm' => sub {
 421         # shamelessly taken and adapted from diagnostics.pm
 422         use Config;
 423         my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 424         if ($^O eq 'VMS') {
 425             require VMS::Filespec;
 426             $privlib = VMS::Filespec::unixify($privlib);
 427             $archlib = VMS::Filespec::unixify($archlib);
 428         }
 429
 430         for (
 431               "pod/perldiag.pod",
 432               "Pod/perldiag.pod",
 433               "pod/perldiag-$Config{version}.pod",
 434               "Pod/perldiag-$Config{version}.pod",
 435               "pods/perldiag.pod",
 436               "pods/perldiag-$Config{version}.pod",
 437         ) {
 438             return $_ if _find_in_inc($_);
 439         }
 440
 441         for (
 442               "$archlib/pods/perldiag.pod",
 443               "$privlib/pods/perldiag-$Config{version}.pod",
 444               "$privlib/pods/perldiag.pod",
 445         ) {
 446             return $_ if -f $_;
 447         }
 448
 449         return 'pod/perldiag.pod';
 450     },
 451     'threads/shared.pm' => [qw( attributes.pm )],
 452     # anybody using threads::shared is likely to declare variables
 453     # with attribute :shared
 454     'utf8.pm' => [
 455         'utf8_heavy.pl', do {
 456             my $dir = 'unicore';
 457             my @subdirs = qw( To );
 458             my @files = map "$dir/lib/$_->{name}", _glob_in_inc("$dir/lib");
 459
 460             if (@files) {
 461                 # 5.8.x
 462                 push @files, (map "$dir/$_.pl", qw( Exact Canonical ));
 463             }
 464             else {
 465                 # 5.6.x
 466                 $dir = 'unicode';
 467                 @files = map "$dir/Is/$_->{name}", _glob_in_inc("$dir/Is")
 468                   or return;
 469                 push @subdirs, 'In';
 470             }
 471
 472             foreach my $subdir (@subdirs) {
 473                 foreach (_glob_in_inc("$dir/$subdir")) {
 474                     push @files, "$dir/$subdir/$_->{name}";
 475                 }
 476             }
 477             @files;
 478         }
 479     ],
 480     'charnames.pm' => [
 481         _find_in_inc('unicore/Name.pl') ? 'unicore/Name.pl' : 'unicode/Name.pl'
 482     ],
 483 );
 484
 485 # }}}
 486
 487 sub path_to_inc_name($$) {
 488     my $path = shift;
 489     my $warn = shift;
 490     my $inc_name;
 491
 492     if ($path =~ m/\.pm$/io) {
 493         die "$path doesn't exist" unless (-f $path);
 494         my $module_info = Module::Build::ModuleInfo->new_from_file($path);
 495         die "Module::Build::ModuleInfo error: $!" unless defined($module_info);
 496         $inc_name = $module_info->name();
 497         if (defined($inc_name)) {
 498             $inc_name =~ s|\:\:|\/|og;
 499             $inc_name .= '.pm';
 500         } else {
 501             warn "# Couldn't find include name for $path\n" if $warn;
 502         }
 503     } else {
 504         # Bad solution!
 505         (my $vol, my $dir, $inc_name) = File::Spec->splitpath($path);
 506     }
 507
 508     return $inc_name;
 509 }
 510
 511 my $Keys = 'files|keys|recurse|rv|skip|first|execute|compile|warn_missing|cache_cb|cache_file';
 512 sub scan_deps {
 513     my %args = (
 514         rv => {},
 515         (@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
 516     );
 517
 518     if (!defined($args{keys})) {
 519         $args{keys} = [map {path_to_inc_name($_, $args{warn_missing})} @{$args{files}}];
 520     }
 521     my $cache_file = $args{cache_file};
 522     my $using_cache;
 523     if ($cache_file) {
 524         require Module::ScanDeps::Cache;
 525         $using_cache = Module::ScanDeps::Cache::init_from_file($cache_file);
 526         if( $using_cache ){
 527             $args{cache_cb} = Module::ScanDeps::Cache::get_cache_cb();
 528         }else{
 529             my @missing = Module::ScanDeps::Cache::prereq_missing();
 530             warn join(' ',
 531                       "Can not use cache_file: Needs Modules [",
 532                       @missing,
 533                       "]\n",);
 534         }
 535     }
 536     my ($type, $path);
 537     foreach my $input_file (@{$args{files}}) {
 538         if ($input_file !~ $ScanFileRE) {
 539             warn "Skipping input file $input_file because it matches \$Module::ScanDeps::ScanFileRE\n" if $args{warn_missing};
 540             next;
 541         }
 542
 543         $type = _gettype($input_file);
 544         $path = $input_file;
 545         if ($type eq 'module') {
 546             # necessary because add_deps does the search for shared libraries and such
 547             add_deps(
 548                 used_by => undef,
 549                 rv => $args{rv},
 550                 modules => [path_to_inc_name($path, $args{warn_missing})],
 551                 skip => undef,
 552                 warn_missing => $args{warn_missing},
 553             );
 554         }
 555         else {
 556             _add_info(
 557                 rv      => $args{rv},
 558                 module  => path_to_inc_name($path, $args{warn_missing}),
 559                 file    => $path,
 560                 used_by => undef,
 561                 type    => $type,
 562             );
 563         }
 564     }
 565
 566     scan_deps_static(\%args);
 567
 568     if ($args{execute} or $args{compile}) {
 569         scan_deps_runtime(
 570             rv      => $args{rv},
 571             files   => $args{files},
 572             execute => $args{execute},
 573             compile => $args{compile},
 574             skip    => $args{skip}
 575         );
 576     }
 577
 578     if ( $using_cache ){
 579         Module::ScanDeps::Cache::store_cache();
 580     }
 581
 582     # do not include the input files themselves as dependencies!
 583     delete $args{rv}{$_} foreach @{$args{files}};
 584
 585     return ($args{rv});
 586 }
 587
 588 sub scan_deps_static {
 589     my ($args) = @_;
 590     my ($files,  $keys, $recurse, $rv,
 591         $skip,  $first, $execute, $compile,
 592         $cache_cb, $_skip)
 593         = @$args{qw( files keys  recurse rv
 594                      skip  first execute compile
 595                      cache_cb _skip )};
 596
 597     $rv   ||= {};
 598     $_skip ||= { %{$skip || {}} };
 599
 600     foreach my $file (@{$files}) {
 601         my $key = shift @{$keys};
 602         next if $_skip->{$file}++;
 603         next if is_insensitive_fs()
 604           and $file ne lc($file) and $_skip->{lc($file)}++;
 605         next unless $file =~ $ScanFileRE;
 606
 607         my @pm;
 608         my $found_in_cache;
 609         if ($cache_cb){
 610             my $pm_aref;
 611             # cache_cb populates \@pm on success
 612             $found_in_cache = $cache_cb->(action => 'read',
 613                                           key    => $key,
 614                                           file   => $file,
 615                                           modules => \@pm,
 616                                       );
 617             unless( $found_in_cache ){
 618                 @pm = scan_file($file);
 619                 $cache_cb->(action => 'write',
 620                             key    => $key,
 621                             file   => $file,
 622                             modules => \@pm,
 623                         );
 624             }
 625         }else{ # no caching callback given
 626             @pm = scan_file($file);
 627         }
 628
 629         foreach my $pm (@pm){
 630             add_deps(
 631                      used_by => $key,
 632                      rv      => $args->{rv},
 633                      modules => [$pm],
 634                      skip    => $args->{skip},
 635                      warn_missing => $args->{warn_missing},
 636                  );
 637
 638             my $preload = _get_preload($pm) or next;
 639
 640             add_deps(
 641                      used_by => $key,
 642                      rv      => $args->{rv},
 643                      modules => $preload,
 644                      skip    => $args->{skip},
 645                      warn_missing => $args->{warn_missing},
 646                  );
 647         }
 648     }
 649
 650     # Top-level recursion handling {{{
 651
 652     while ($recurse) {
 653         my $count = keys %$rv;
 654         my @files = sort grep { defined $_->{file} && -T $_->{file} } values %$rv;
 655         scan_deps_static({
 656             files    => [ map $_->{file}, @files ],
 657             keys     => [ map $_->{key},  @files ],
 658             rv       => $rv,
 659             skip     => $skip,
 660             recurse  => 0,
 661             cache_cb => $cache_cb,
 662             _skip    => $_skip,
 663         }) or ($args->{_deep} and return);
 664         last if $count == keys %$rv;
 665     }
 666
 667     # }}}
 668
 669     return $rv;
 670 }
 671
 672 sub scan_deps_runtime {
 673     my %args = (
 674         perl => $^X,
 675         rv   => {},
 676         (@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
 677     );
 678     my ($files, $rv, $execute, $compile, $skip, $perl) =
 679       @args{qw( files rv execute compile skip perl )};
 680
 681     $files = (ref($files)) ? $files : [$files];
 682
 683     my ($inchash, $incarray, $dl_shared_objects) = ({}, [], []);
 684     if ($compile) {
 685         my $file;
 686
 687         foreach $file (@$files) {
 688             next unless $file =~ $ScanFileRE;
 689
 690             ($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
 691             _compile($perl, $file, $inchash, $dl_shared_objects, $incarray);
 692
 693             my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
 694             _merge_rv($rv_sub, $rv);
 695         }
 696     }
 697     elsif ($execute) {
 698         my $excarray = (ref($execute)) ? $execute : [@$files];
 699         my $exc;
 700         my $first_flag = 1;
 701         foreach $exc (@$excarray) {
 702             ($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
 703             _execute(
 704                 $perl, $exc, $inchash, $dl_shared_objects, $incarray,
 705                 $first_flag
 706             );
 707             $first_flag = 0;
 708         }
 709
 710         # XXX only retains data from last execute ...  Why? I suspect
 711         # the above loop was added later.  Needs test cases --Eric
 712         my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
 713         _merge_rv($rv_sub, $rv);
 714     }
 715
 716     return ($rv);
 717 }
 718
 719 sub scan_file{
 720     my $file = shift;
 721     my %found;
 722     my $FH;
 723     open $FH, $file or die "Cannot open $file: $!";
 724
 725     $SeenTk = 0;
 726     # Line-by-line scanning
 727   LINE:
 728     while (<$FH>) {
 729         chomp(my $line = $_);
 730         foreach my $pm (scan_line($line)) {
 731             last LINE if $pm eq '__END__';
 732
 733             # Skip Tk hits from Term::ReadLine and Tcl::Tk
 734             my $pathsep = qr/\/|\\|::/;
 735             if ($pm =~ /^Tk\b/) {
 736                 next if $file =~ /(?:^|${pathsep})Term${pathsep}ReadLine\.pm$/;
 737                 next if $file =~ /(?:^|${pathsep})Tcl${pathsep}Tk\W/;
 738             }
 739             if ($pm eq '__POD__') {
 740                 while (<$FH>) {
 741                     last if (/^=cut/);
 742                 }
 743                 next LINE;
 744             }
 745             $SeenTk || do{$SeenTk = 1 if $pm =~ /Tk\.pm$/;};
 746             # the following line does not make much sense here ???
 747             # $file is an absolute path and will never match
 748             #$pm = 'CGI/Apache.pm' if $file =~ /^Apache(?:\.pm)$/;
 749             $found{$pm}++;
 750         }
 751     }
 752     close $FH or die "Cannot close $file: $!";
 753     return keys %found;
 754 }
 755
 756 sub scan_line {
 757     my $line = shift;
 758     my %found;
 759
 760     return '__END__' if $line =~ /^__(?:END|DATA)__$/;
 761     return '__POD__' if $line =~ /^=\w/;
 762
 763     $line =~ s/\s*#.*$//;
 764     $line =~ s/[\\\/]+/\//g;
 765
 766     foreach (split(/;/, $line)) {
 767         if (/^\s*package\s+(\w+)/) {
 768             $CurrentPackage = $1;
 769             $CurrentPackage =~ s{::}{/}g;
 770             return;
 771         }
 772         # use VERSION:
 773         if (/^\s*(?:use|require)\s+v?(\d[\d\._]*)/) {
 774           # include feature.pm if we have 5.9.5 or better
 775           if (version->new($1) >= version->new("5.9.5")) {
 776               # seems to catch 5.9, too (but not 5.9.4)
 777             return "feature.pm";
 778           }
 779         }
 780
 781         if (my ($autouse) = /^\s*use\s+autouse\s+(["'].*?["']|\w+)/)
 782         {
 783             $autouse =~ s/["']//g;
 784             $autouse =~ s{::}{/}g;
 785             return ("autouse.pm", "$autouse.pm");
 786         }
 787
 788         if (my ($libs) = /\b(?:use\s+lib\s+|(?:unshift|push)\W+\@INC\W+)(.+)/)
 789         {
 790             my $archname = defined($Config{archname}) ? $Config{archname} : '';
 791             my $ver = defined($Config{version}) ? $Config{version} : '';
 792             foreach (grep(/\w/, split(/["';() ]/, $libs))) {
 793                 unshift(@INC, "$_/$ver")           if -d "$_/$ver";
 794                 unshift(@INC, "$_/$archname")      if -d "$_/$archname";
 795                 unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname";
 796             }
 797             next;
 798         }
 799
 800         $found{$_}++ for scan_chunk($_);
 801     }
 802
 803     return sort keys %found;
 804 }
 805
 806 # short helper for scan_chunk
 807 sub _typical_module_loader_chunk {
 808   local $_ = shift;
 809   my $loader = shift;
 810   my $prefix='';
 811   if (@_ and $_[0]) {
 812     $prefix=$_[0].'::';
 813   }
 814   my $loader_file = $loader;
 815   $loader_file =~ s/::/\//;
 816   $loader_file .= ".pm";
 817   $loader = quotemeta($loader);
 818
 819   if (/^\s* use \s+ $loader(?!\:) \b \s* (.*)/sx) {
 820     return [
 821       $loader_file,
 822       map { my $mod="$prefix$_";$mod=~s{::}{/}g; "$mod.pm" }
 823       grep { length and !/^q[qw]?$/ and !/-/ } split(/[^\w:-]+/, $1)
 824       #should skip any module name that contains '-', not split it in two
 825     ];
 826   }
 827   return();
 828 }
 829
 830 sub scan_chunk {
 831     my $chunk = shift;
 832
 833     # Module name extraction heuristics {{{
 834     my $module = eval {
 835         $_ = $chunk;
 836
 837         # TODO: There's many more of these "loader" type modules on CPAN!
 838         # scan for the typical module-loader modules
 839         foreach my $loader (qw(asa base parent prefork POE encoding maybe only::matching)) {
 840           my $retval = _typical_module_loader_chunk($_, $loader);
 841           return $retval if $retval;
 842         }
 843
 844         foreach my $loader (qw(Catalyst)) {
 845           my $retval = _typical_module_loader_chunk($_, $loader,'Catalyst::Plugin');
 846           return $retval if $retval;
 847         }
 848
 849         return [ 'Class/Autouse.pm',
 850             map { s{::}{/}g; "$_.pm" }
 851               grep { length and !/^:|^q[qw]?$/ } split(/[^\w:]+/, $1) ]
 852           if /^\s* use \s+ Class::Autouse \b \s* (.*)/sx
 853               or /^\s* Class::Autouse \s* -> \s* autouse \s* (.*)/sx;
 854
 855         return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']+)/;
 856         return $1
 857           if /(?:^|\s)(?:use|no|require)\s+\(\s*([\w:\.\-\\\/\"\']+)\s*\)/;
 858
 859         if (   s/(?:^|\s)eval\s+\"([^\"]+)\"/$1/
 860             or s/(?:^|\s)eval\s*\(\s*\"([^\"]+)\"\s*\)/$1/)
 861         {
 862             return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']*)/;
 863         }
 864
 865         if (/(<[^>]*[^\$\w>][^>]*>)/) {
 866             my $diamond = $1;
 867             return "File/Glob.pm" if $diamond =~ /[*?\[\]{}~\\]/;
 868         }
 869         return "DBD/$1.pm"    if /\b[Dd][Bb][Ii]:(\w+):/;
 870         if (/(?:(:encoding)|\b(?:en|de)code)\(\s*['"]?([-\w]+)/) {
 871             my $mod = _find_encoding($2);
 872             return [ 'PerlIO.pm', $mod ] if $1 and $mod;
 873             return $mod if $mod;
 874         }
 875         return $1 if /(?:^|\s)(?:do|require)\s+[^"]*"(.*?)"/;
 876         return $1 if /(?:^|\s)(?:do|require)\s+[^']*'(.*?)'/;
 877         return $1 if /[^\$]\b([\w:]+)->\w/ and $1 ne 'Tk' and $1 ne 'shift';
 878         return $1 if /\b(\w[\w:]*)::\w+\(/ and $1 ne 'main' and $1 ne 'SUPER';
 879
 880         if ($SeenTk) {
 881             my @modules;
 882             while (/->\s*([A-Z]\w+)/g) {
 883                 push @modules, "Tk/$1.pm";
 884             }
 885             while (/->\s*Scrolled\W+([A-Z]\w+)/g) {
 886                 push @modules, "Tk/$1.pm";
 887                 push @modules, "Tk/Scrollbar.pm";
 888             }
 889             if (/->\s*setPalette/g) {
 890                 push @modules,
 891                   map { "Tk/$_.pm" }
 892                   qw( Button Canvas Checkbutton Entry
 893                       Frame Label Labelframe Listbox
 894                       Menubutton Menu Message Radiobutton
 895                       Scale Scrollbar Spinbox Text );
 896             }
 897             return \@modules;
 898         }
 899         return;
 900     };
 901
 902     # }}}
 903
 904     return unless defined($module);
 905     return wantarray ? @$module : $module->[0] if ref($module);
 906
 907     $module =~ s/^['"]//;
 908     return unless $module =~ /^\w/;
 909
 910     $module =~ s/\W+$//;
 911     $module =~ s/::/\//g;
 912     return if $module =~ /^(?:[\d\._]+|'.*[^']|".*[^"])$/;
 913
 914     $module .= ".pm" unless $module =~ /\./;
 915     return $module;
 916 }
 917
 918 sub _find_encoding {
 919     return unless $] >= 5.008 and eval { require Encode; %Encode::ExtModule };
 920
 921     my $mod = $Encode::ExtModule{ Encode::find_encoding($_[0])->name }
 922       or return;
 923     $mod =~ s{::}{/}g;
 924     return "$mod.pm";
 925 }
 926
 927 sub _add_info {
 928     my %args = @_;
 929     my ($rv, $module, $file, $used_by, $type) = @args{qw/rv module file used_by type/};
 930
 931     return unless defined($module) and defined($file);
 932
 933     # Ensure file is always absolute
 934     $file = File::Spec->rel2abs($file);
 935     $file =~ s|\\|\/|go;
 936
 937     # Avoid duplicates that can arise due to case differences that don't actually
 938     # matter on a case tolerant system
 939     if (File::Spec->case_tolerant()) {
 940         foreach my $key (keys %$rv) {
 941             if (lc($key) eq lc($module)) {
 942                 $module = $key;
 943                 last;
 944             }
 945         }
 946         if (defined($used_by)) {
 947             if (lc($used_by) eq lc($module)) {
 948                 $used_by = $module;
 949             } else {
 950                 foreach my $key (keys %$rv) {
 951                     if (lc($key) eq lc($used_by)) {
 952                         $used_by = $key;
 953                         last;
 954                     }
 955                 }
 956             }
 957         }
 958     }
 959
 960     $rv->{$module} ||= {
 961         file => $file,
 962         key  => $module,
 963         type => $type,
 964     };
 965
 966     if (defined($used_by) and $used_by ne $module) {
 967         push @{ $rv->{$module}{used_by} }, $used_by
 968           if  ( (!File::Spec->case_tolerant() && !grep { $_ eq $used_by } @{ $rv->{$module}{used_by} })
 969              or ( File::Spec->case_tolerant() && !grep { lc($_) eq lc($used_by) } @{ $rv->{$module}{used_by} }));
 970
 971         # We assume here that another _add_info will be called to provide the other parts of $rv->{$used_by}
 972         push @{ $rv->{$used_by}{uses} }, $module
 973           if  ( (!File::Spec->case_tolerant() && !grep { $_ eq $module } @{ $rv->{$used_by}{uses} })
 974              or ( File::Spec->case_tolerant() && !grep { lc($_) eq lc($module) } @{ $rv->{$used_by}{uses} }));
 975     }
 976 }
 977
 978 # This subroutine relies on not being called for modules that have already been visited
 979 sub add_deps {
 980     my %args =
 981       ((@_ and $_[0] =~ /^(?:modules|rv|used_by|warn_missing)$/)
 982         ? @_
 983         : (rv => (ref($_[0]) ? shift(@_) : undef), modules => [@_]));
 984
 985     my $rv = $args{rv}   || {};
 986     my $skip = $args{skip} || {};
 987     my $used_by = $args{used_by};
 988
 989     foreach my $module (@{ $args{modules} }) {
 990         my $file = _find_in_inc($module)
 991           or _warn_of_missing_module($module, $args{warn_missing}), next;
 992         next if $skip->{$file};
 993
 994         if (exists $rv->{$module}) {
 995             _add_info( rv     => $rv,      module  => $module,
 996                        file   => $file,    used_by => $used_by,
 997                        type   => undef );
 998             next;
 999         }
1000
1001         my $type = _gettype($file);
1002         _add_info( rv     => $rv,   module  => $module,
1003                    file   => $file, used_by => $used_by,
1004                    type   => $type );
1005
1006         if ($module =~ /(.*?([^\/]*))\.p[mh]$/i) {
1007             my ($path, $basename) = ($1, $2);
1008
1009             foreach (_glob_in_inc("auto/$path")) {
1010                 next if $_->{file} =~ m{\bauto/$path/.*/};  # weed out subdirs
1011                 next if $_->{name} =~ m/(?:^|\/)\.(?:exists|packlist)$/;
1012                 my ($ext,$type);
1013                 $ext = lc($1) if $_->{name} =~ /(\.[^.]+)$/;
1014                 if (defined $ext) {
1015                     next if $ext eq lc(lib_ext());
1016                     $type = 'shared' if $ext eq lc(dl_ext());
1017                     $type = 'autoload' if ($ext eq '.ix' or $ext eq '.al');
1018                 }
1019                 $type ||= 'data';
1020
1021                 _add_info( rv     => $rv,        module  => "auto/$path/$_->{name}",
1022                            file   => $_->{file}, used_by => $module,
1023                            type   => $type );
1024             }
1025         }
1026     } # end for modules
1027     return $rv;
1028 }
1029
1030 sub _find_in_inc {
1031     my $file = shift;
1032     return unless defined $file;
1033
1034     foreach my $dir (grep !/\bBSDPAN\b/, @INC, @IncludeLibs) {
1035         return "$dir/$file" if -f "$dir/$file";
1036     }
1037
1038     # absolute file names
1039     return $file if -f $file;
1040
1041     return;
1042 }
1043
1044 sub _glob_in_inc {
1045     my $subdir  = shift;
1046     my $pm_only = shift;
1047     my @files;
1048
1049     require File::Find;
1050
1051     $subdir =~ s/\$CurrentPackage/$CurrentPackage/;
1052
1053     foreach my $dir (map "$_/$subdir", grep !/\bBSDPAN\b/, @INC, @IncludeLibs) {
1054         next unless -d $dir;
1055         File::Find::find(
1056             sub {
1057                 my $name = $File::Find::name;
1058                 $name =~ s!^\Q$dir\E/!!;
1059                 return if $pm_only and lc($name) !~ /\.p[mh]$/i;
1060                 push @files, $pm_only
1061                   ? "$subdir/$name"
1062                   : {             file => $File::Find::name,
1063                     name => $name,
1064                   }
1065                   if -f;
1066             },
1067             $dir
1068         );
1069     }
1070
1071     return @files;
1072 }
1073
1074 # App::Packer compatibility functions
1075
1076 sub new {
1077     my ($class, $self) = @_;
1078     return bless($self ||= {}, $class);
1079 }
1080
1081 sub set_file {
1082     my $self = shift;
1083     foreach my $script (@_) {
1084         my ($vol, $dir, $file) = File::Spec->splitpath($script);
1085         $self->{main} = {
1086             key  => $file,
1087             file => $script,
1088         };
1089     }
1090 }
1091
1092 sub set_options {
1093     my $self = shift;
1094     my %args = @_;
1095     foreach my $module (@{ $args{add_modules} }) {
1096         $module =~ s/::/\//g;
1097         $module .= '.pm' unless $module =~ /\.p[mh]$/i;
1098         my $file = _find_in_inc($module)
1099           or _warn_of_missing_module($module, $args{warn_missing}), next;
1100         $self->{files}{$module} = $file;
1101     }
1102 }
1103
1104 sub calculate_info {
1105     my $self = shift;
1106     my $rv   = scan_deps(
1107         'keys' => [ $self->{main}{key}, sort keys %{ $self->{files} }, ],
1108         files  => [ $self->{main}{file},
1109             map { $self->{files}{$_} } sort keys %{ $self->{files} },
1110         ],
1111         recurse => 1,
1112     );
1113
1114     my $info = {
1115         main => {  file     => $self->{main}{file},
1116                    store_as => $self->{main}{key},
1117         },
1118     };
1119
1120     my %cache = ($self->{main}{key} => $info->{main});
1121     foreach my $key (sort keys %{ $self->{files} }) {
1122         my $file = $self->{files}{$key};
1123
1124         $cache{$key} = $info->{modules}{$key} = {
1125             file     => $file,
1126             store_as => $key,
1127             used_by  => [ $self->{main}{key} ],
1128         };
1129     }
1130
1131     foreach my $key (sort keys %{$rv}) {
1132         my $val = $rv->{$key};
1133         if ($cache{ $val->{key} }) {
1134             defined($val->{used_by}) or next;
1135             push @{ $info->{ $val->{type} }->{ $val->{key} }->{used_by} },
1136               @{ $val->{used_by} };
1137         }
1138         else {
1139             $cache{ $val->{key} } = $info->{ $val->{type} }->{ $val->{key} } =
1140               {        file     => $val->{file},
1141                 store_as => $val->{key},
1142                 used_by  => $val->{used_by},
1143               };
1144         }
1145     }
1146
1147     $self->{info} = { main => $info->{main} };
1148
1149     foreach my $type (sort keys %{$info}) {
1150         next if $type eq 'main';
1151
1152         my @val;
1153         if (UNIVERSAL::isa($info->{$type}, 'HASH')) {
1154             foreach my $val (sort values %{ $info->{$type} }) {
1155                 @{ $val->{used_by} } = map $cache{$_} || "!!$_!!",
1156                   @{ $val->{used_by} };
1157                 push @val, $val;
1158             }
1159         }
1160
1161         $type = 'modules' if $type eq 'module';
1162         $self->{info}{$type} = \@val;
1163     }
1164 }
1165
1166 sub get_files {
1167     my $self = shift;
1168     return $self->{info};
1169 }
1170
1171 # scan_deps_runtime utility functions
1172
1173 sub _compile {
1174     my ($perl, $file, $inchash, $dl_shared_objects, $incarray) = @_;
1175
1176     my ($fhout, $fname) = File::Temp::tempfile("XXXXXX");
1177     my $fhin  = FileHandle->new($file) or die "Couldn't open $file\n";
1178
1179     my $line = do { local $/; <$fhin> };
1180     $line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
1181     $line =~ s/^(.*?)((?:[\r\n]+__(?:DATA|END)__[\r\n]+)|$)/
1182 use Module::ScanDeps::DataFeed '$fname.out';
1183 sub {
1184 $1
1185 }
1186 $2/s;
1187     $fhout->print($line);
1188     $fhout->close;
1189     $fhin->close;
1190
1191     system($perl, $fname);
1192
1193     _extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
1194     unlink("$fname");
1195     unlink("$fname.out");
1196 }
1197
1198 sub _execute {
1199     my ($perl, $file, $inchash, $dl_shared_objects, $incarray, $firstflag) = @_;
1200
1201     $DB::single = $DB::single = 1;
1202     my ($fhout, $fname) = File::Temp::tempfile("XXXXXX");
1203     $fname = _abs_path($fname);
1204     my $fhin  = FileHandle->new($file) or die "Couldn't open $file";
1205
1206     my $line = do { local $/; <$fhin> };
1207     $line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
1208     $line = "use Module::ScanDeps::DataFeed '$fname.out';\n" . $line;
1209     $fhout->print($line);
1210     $fhout->close;
1211     $fhin->close;
1212
1213     File::Path::rmtree( ['_Inline'], 0, 1); # XXX hack
1214     system($perl, (map { "-I$_" } @IncludeLibs), $fname) == 0 or die "SYSTEM ERROR in executing $file: $?";
1215
1216     _extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
1217     unlink("$fname");
1218     unlink("$fname.out");
1219 }
1220
1221 # create a new hashref, applying fixups
1222 sub _make_rv {
1223     my ($inchash, $dl_shared_objects, $inc_array) = @_;
1224
1225     my $rv = {};
1226     my @newinc = map(quotemeta($_), @$inc_array);
1227     my $inc = join('|', sort { length($b) <=> length($a) } @newinc);
1228     # don't pack lib/c:/ or lib/C:/
1229     $inc = qr/$inc/i if(is_insensitive_fs());
1230
1231     require File::Spec;
1232
1233     my $key;
1234     foreach $key (keys(%$inchash)) {
1235         my $newkey = $key;
1236         $newkey =~ s"^(?:(?:$inc)/?)""sg if File::Spec->file_name_is_absolute($newkey);
1237
1238         $rv->{$newkey} = {
1239             'used_by' => [],
1240             'file'    => $inchash->{$key},
1241             'type'    => _gettype($inchash->{$key}),
1242             'key'     => $key
1243         };
1244     }
1245
1246     my $dl_file;
1247     foreach $dl_file (@$dl_shared_objects) {
1248         my $key = $dl_file;
1249         $key =~ s"^(?:(?:$inc)/?)""s;
1250
1251         $rv->{$key} = {
1252             'used_by' => [],
1253             'file'    => $dl_file,
1254             'type'    => 'shared',
1255             'key'     => $key
1256         };
1257     }
1258
1259     return $rv;
1260 }
1261
1262 sub _extract_info {
1263     my ($fname, $inchash, $dl_shared_objects, $incarray) = @_;
1264
1265     use vars qw(%inchash @dl_shared_objects @incarray);
1266     my $fh = FileHandle->new($fname) or die "Couldn't open $fname";
1267     my $line = do { local $/; <$fh> };
1268     $fh->close;
1269
1270     eval $line;
1271
1272     $inchash->{$_} = $inchash{$_} for keys %inchash;
1273     @$dl_shared_objects = @dl_shared_objects;
1274     @$incarray          = @incarray;
1275 }
1276
1277 sub _gettype {
1278     my $name = shift;
1279     my $dlext = quotemeta(dl_ext());
1280
1281     return 'autoload' if $name =~ /(?:\.ix|\.al)$/i;
1282     return 'module'   if $name =~ /\.p[mh]$/i;
1283     return 'shared'   if $name =~ /\.$dlext$/i;
1284     return 'data';
1285 }
1286
1287 # merge all keys from $rv_sub into the $rv mega-ref
1288 sub _merge_rv {
1289     my ($rv_sub, $rv) = @_;
1290
1291     my $key;
1292     foreach $key (keys(%$rv_sub)) {
1293         my %mark;
1294         if ($rv->{$key} and _not_dup($key, $rv, $rv_sub)) {
1295             warn "Different modules for file '$key' were found.\n"
1296                 . " -> Using '" . _abs_path($rv_sub->{$key}{file}) . "'.\n"
1297                 . " -> Ignoring '" . _abs_path($rv->{$key}{file}) . "'.\n";
1298             $rv->{$key}{used_by} = [
1299                 grep (!$mark{$_}++,
1300                     @{ $rv->{$key}{used_by} },
1301                     @{ $rv_sub->{$key}{used_by} })
1302             ];
1303             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
1304             $rv->{$key}{file} = $rv_sub->{$key}{file};
1305         }
1306         elsif ($rv->{$key}) {
1307             $rv->{$key}{used_by} = [
1308                 grep (!$mark{$_}++,
1309                     @{ $rv->{$key}{used_by} },
1310                     @{ $rv_sub->{$key}{used_by} })
1311             ];
1312             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
1313         }
1314         else {
1315             $rv->{$key} = {
1316                 used_by => [ @{ $rv_sub->{$key}{used_by} } ],
1317                 file    => $rv_sub->{$key}{file},
1318                 key     => $rv_sub->{$key}{key},
1319                 type    => $rv_sub->{$key}{type}
1320             };
1321
1322             @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
1323         }
1324     }
1325 }
1326
1327 sub _not_dup {
1328     my ($key, $rv1, $rv2) = @_;
1329     if (File::Spec->case_tolerant()) {
1330         return lc(_abs_path($rv1->{$key}{file})) ne lc(_abs_path($rv2->{$key}{file}));
1331     }
1332     else {
1333         return _abs_path($rv1->{$key}{file}) ne _abs_path($rv2->{$key}{file});
1334     }
1335 }
1336
1337 sub _abs_path {
1338     return join(
1339         '/',
1340         Cwd::abs_path(File::Basename::dirname($_[0])),
1341         File::Basename::basename($_[0]),
1342     );
1343 }
1344
1345
1346 sub _warn_of_missing_module {
1347     my $module = shift;
1348     my $warn = shift;
1349     return if not $warn;
1350     return if not $module =~ /\.p[ml]$/;
1351     warn "# Could not find source file '$module' in \@INC or \@IncludeLibs. Skipping it.\n"
1352       if not -f $module;
1353 }
1354
1355 sub _get_preload {
1356     my $pm = shift;
1357     my $preload = $Preload{$pm} or return();
1358     if ($preload eq 'sub') {
1359         $pm =~ s/\.p[mh]$//i;
1360         $preload = [ _glob_in_inc($pm, 1) ];
1361     }
1362     elsif (UNIVERSAL::isa($preload, 'CODE')) {
1363         $preload = [ $preload->($pm) ];
1364     }
1365     return $preload;
1366 }
1367
1368 1;
1369 __END__
1370
1371 =head1 SEE ALSO
1372
1373 L<scandeps.pl> is a bundled utility that writes C<PREREQ_PM> section
1374 for a number of files.
1375
1376 An application of B<Module::ScanDeps> is to generate executables from
1377 scripts that contains prerequisite modules; this module supports two
1378 such projects, L<PAR> and L<App::Packer>.  Please see their respective
1379 documentations on CPAN for further information.
1380
1381 =head1 AUTHORS
1382
1383 Audrey Tang E<lt>cpan@audreyt.orgE<gt>
1384
1385 To a lesser degree: Steffen Mueller E<lt>smueller@cpan.orgE<gt>
1386
1387 Parts of heuristics were deduced from:
1388
1389 =over 4
1390
1391 =item *
1392
1393 B<PerlApp> by ActiveState Tools Corp L<http://www.activestate.com/>
1394
1395 =item *
1396
1397 B<Perl2Exe> by IndigoStar, Inc L<http://www.indigostar.com/>
1398
1399 =back
1400
1401 The B<scan_deps_runtime> function is contributed by Edward S. Peschko.
1402
1403 L<http://par.perl.org/> is the official website for this module.  You
1404 can write to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty
1405 mail to E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
1406
1407 Please submit bug reports to E<lt>bug-Module-ScanDeps@rt.cpan.orgE<gt>.
1408
1409 =head1 COPYRIGHT
1410
1411 Copyright 2002-2008 by
1412 Audrey Tang E<lt>cpan@audreyt.orgE<gt>;
1413 2005-2009 by Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
1414
1415 This program is free software; you can redistribute it and/or modify it
1416 under the same terms as Perl itself.
1417
1418 See L<http://www.perl.com/perl/misc/Artistic.html>
1419
1420 =cut