1084 lines
31 KiB
Perl
1084 lines
31 KiB
Perl
package Module::ScanDeps;
|
|
|
|
use 5.004;
|
|
use strict;
|
|
use vars qw( $VERSION @EXPORT @EXPORT_OK $CurrentPackage );
|
|
|
|
$VERSION = '0.62';
|
|
@EXPORT = qw( scan_deps scan_deps_runtime );
|
|
@EXPORT_OK = qw( scan_line scan_chunk add_deps scan_deps_runtime );
|
|
|
|
use Config;
|
|
use Exporter;
|
|
use base 'Exporter';
|
|
use constant dl_ext => ".$Config{dlext}";
|
|
use constant lib_ext => $Config{lib_ext};
|
|
use constant is_insensitive_fs => (
|
|
-s $0
|
|
and (-s lc($0) || -1) == (-s uc($0) || -1)
|
|
and (-s lc($0) || -1) == -s $0
|
|
);
|
|
|
|
use Cwd ();
|
|
use File::Path ();
|
|
use File::Temp ();
|
|
use File::Basename ();
|
|
use FileHandle;
|
|
|
|
=head1 NAME
|
|
|
|
Module::ScanDeps - Recursively scan Perl code for dependencies
|
|
|
|
=head1 VERSION
|
|
|
|
This document describes version 0.61 of Module::ScanDeps, released
|
|
June 30, 2006.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Via the command-line program L<scandeps.pl>:
|
|
|
|
% scandeps.pl *.pm # Print PREREQ_PM section for *.pm
|
|
% scandeps.pl -e "use utf8" # Read script from command line
|
|
% scandeps.pl -B *.pm # Include core modules
|
|
% scandeps.pl -V *.pm # Show autoload/shared/data files
|
|
|
|
Used in a program;
|
|
|
|
use Module::ScanDeps;
|
|
|
|
# standard usage
|
|
my $hash_ref = scan_deps(
|
|
files => [ 'a.pl', 'b.pl' ],
|
|
recurse => 1,
|
|
);
|
|
|
|
# shorthand; assume recurse == 1
|
|
my $hash_ref = scan_deps( 'a.pl', 'b.pl' );
|
|
|
|
# App::Packer::Frontend compatible interface
|
|
# see App::Packer::Frontend for the structure returned by get_files
|
|
my $scan = Module::ScanDeps->new;
|
|
$scan->set_file( 'a.pl' );
|
|
$scan->set_options( add_modules => [ 'Test::More' ] );
|
|
$scan->calculate_info;
|
|
my $files = $scan->get_files;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module scans potential modules used by perl programs, and returns a
|
|
hash reference; its keys are the module names as appears in C<%INC>
|
|
(e.g. C<Test/More.pm>); the values are hash references with this structure:
|
|
|
|
{
|
|
file => '/usr/local/lib/perl5/5.8.0/Test/More.pm',
|
|
key => 'Test/More.pm',
|
|
type => 'module', # or 'autoload', 'data', 'shared'
|
|
used_by => [ 'Test/Simple.pm', ... ],
|
|
}
|
|
|
|
One function, C<scan_deps>, is exported by default. Three other
|
|
functions (C<scan_line>, C<scan_chunk>, C<add_deps>) are exported upon
|
|
request.
|
|
|
|
Users of B<App::Packer> may also use this module as the dependency-checking
|
|
frontend, by tweaking their F<p2e.pl> like below:
|
|
|
|
use Module::ScanDeps;
|
|
...
|
|
my $packer = App::Packer->new( frontend => 'Module::ScanDeps' );
|
|
...
|
|
|
|
Please see L<App::Packer::Frontend> for detailed explanation on
|
|
the structure returned by C<get_files>.
|
|
|
|
=head2 B<scan_deps>
|
|
|
|
$rv_ref = scan_deps(
|
|
files => \@files, recurse => $recurse,
|
|
rv => \%rv, skip => \%skip,
|
|
compile => $compile, execute => $execute,
|
|
);
|
|
$rv_ref = scan_deps(@files); # shorthand, with recurse => 1
|
|
|
|
This function scans each file in C<@files>, registering their
|
|
dependencies into C<%rv>, and returns a reference to the updated
|
|
C<%rv>. The meaning of keys and values are explained above.
|
|
|
|
If C<$recurse> is true, C<scan_deps> will call itself recursively,
|
|
to perform a breadth-first search on text files (as defined by the
|
|
-T operator) found in C<%rv>.
|
|
|
|
If the C<\%skip> is specified, files that exists as its keys are
|
|
skipped. This is used internally to avoid infinite recursion.
|
|
|
|
If C<$compile> or C<$execute> is true, runs C<files> in either
|
|
compile-only or normal mode, then inspects their C<%INC> after
|
|
termination to determine additional runtime dependencies.
|
|
|
|
If C<$execute> is an array reference, runs the files contained
|
|
in it instead of C<@files>.
|
|
|
|
=head2 B<scan_deps_runtime>
|
|
|
|
Like B<scan_deps>, but skips the static scanning part.
|
|
|
|
=head2 B<scan_line>
|
|
|
|
@modules = scan_line($line);
|
|
|
|
Splits a line into chunks (currently with the semicolon characters), and
|
|
return the union of C<scan_chunk> calls of them.
|
|
|
|
If the line is C<__END__> or C<__DATA__>, a single C<__END__> element is
|
|
returned to signify the end of the program.
|
|
|
|
Similarly, it returns a single C<__POD__> if the line matches C</^=\w/>;
|
|
the caller is responsible for skipping appropriate number of lines
|
|
until C<=cut>, before calling C<scan_line> again.
|
|
|
|
=head2 B<scan_chunk>
|
|
|
|
$module = scan_chunk($chunk);
|
|
@modules = scan_chunk($chunk);
|
|
|
|
Apply various heuristics to C<$chunk> to find and return the module
|
|
name(s) it contains. In scalar context, returns only the first module
|
|
or C<undef>.
|
|
|
|
=head2 B<add_deps>
|
|
|
|
$rv_ref = add_deps( rv => \%rv, modules => \@modules );
|
|
$rv_ref = add_deps( @modules ); # shorthand, without rv
|
|
|
|
Resolves a list of module names to its actual on-disk location, by
|
|
finding in C<@INC>; modules that cannot be found are skipped.
|
|
|
|
This function populates the C<%rv> hash with module/filename pairs, and
|
|
returns a reference to it.
|
|
|
|
=head1 CAVEATS
|
|
|
|
This module intentially ignores the B<BSDPAN> hack on FreeBSD -- the
|
|
additional directory is removed from C<@INC> altogether.
|
|
|
|
The static-scanning heuristic is not likely to be 100% accurate, especially
|
|
on modules that dynamically load other modules.
|
|
|
|
Chunks that span multiple lines are not handled correctly. For example,
|
|
this one works:
|
|
|
|
use base 'Foo::Bar';
|
|
|
|
But this one does not:
|
|
|
|
use base
|
|
'Foo::Bar';
|
|
|
|
=cut
|
|
|
|
my $SeenTk;
|
|
|
|
# Pre-loaded module dependencies {{{
|
|
my %Preload = (
|
|
'AnyDBM_File.pm' => [qw( SDBM_File.pm )],
|
|
'Authen/SASL.pm' => 'sub',
|
|
'Bio/AlignIO.pm' => 'sub',
|
|
'Bio/Assembly/IO.pm' => 'sub',
|
|
'Bio/Biblio/IO.pm' => 'sub',
|
|
'Bio/ClusterIO.pm' => 'sub',
|
|
'Bio/CodonUsage/IO.pm' => 'sub',
|
|
'Bio/DB/Biblio.pm' => 'sub',
|
|
'Bio/DB/Flat.pm' => 'sub',
|
|
'Bio/DB/GFF.pm' => 'sub',
|
|
'Bio/DB/Taxonomy.pm' => 'sub',
|
|
'Bio/Graphics/Glyph.pm' => 'sub',
|
|
'Bio/MapIO.pm' => 'sub',
|
|
'Bio/Matrix/IO.pm' => 'sub',
|
|
'Bio/Matrix/PSM/IO.pm' => 'sub',
|
|
'Bio/OntologyIO.pm' => 'sub',
|
|
'Bio/PopGen/IO.pm' => 'sub',
|
|
'Bio/Restriction/IO.pm' => 'sub',
|
|
'Bio/Root/IO.pm' => 'sub',
|
|
'Bio/SearchIO.pm' => 'sub',
|
|
'Bio/SeqIO.pm' => 'sub',
|
|
'Bio/Structure/IO.pm' => 'sub',
|
|
'Bio/TreeIO.pm' => 'sub',
|
|
'Bio/LiveSeq/IO.pm' => 'sub',
|
|
'Bio/Variation/IO.pm' => 'sub',
|
|
'Crypt/Random.pm' => sub {
|
|
_glob_in_inc('Crypt/Random/Provider', 1);
|
|
},
|
|
'Crypt/Random/Generator.pm' => sub {
|
|
_glob_in_inc('Crypt/Random/Provider', 1);
|
|
},
|
|
'DBI.pm' => sub {
|
|
grep !/\bProxy\b/, _glob_in_inc('DBD', 1);
|
|
},
|
|
'DBIx/SearchBuilder.pm' => 'sub',
|
|
'DBIx/ReportBuilder.pm' => 'sub',
|
|
'Device/ParallelPort.pm' => 'sub',
|
|
'Device/SerialPort.pm' => [ qw(
|
|
termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
|
|
) ],
|
|
'ExtUtils/MakeMaker.pm' => sub {
|
|
grep /\bMM_/, _glob_in_inc('ExtUtils', 1);
|
|
},
|
|
'File/Basename.pm' => [qw( re.pm )],
|
|
'File/Spec.pm' => sub {
|
|
require File::Spec;
|
|
map { my $name = $_; $name =~ s!::!/!g; "$name.pm" } @File::Spec::ISA;
|
|
},
|
|
'HTTP/Message.pm' => [ qw(
|
|
URI/URL.pm URI.pm
|
|
) ],
|
|
'IO.pm' => [ qw(
|
|
IO/Handle.pm IO/Seekable.pm IO/File.pm
|
|
IO/Pipe.pm IO/Socket.pm IO/Dir.pm
|
|
) ],
|
|
'IO/Socket.pm' => [qw( IO/Socket/UNIX.pm )],
|
|
'LWP/UserAgent.pm' => [ qw(
|
|
URI/URL.pm URI/http.pm LWP/Protocol/http.pm
|
|
LWP/Protocol/https.pm
|
|
), _glob_in_inc("LWP/Authen", 1) ],
|
|
'Locale/Maketext/Lexicon.pm' => 'sub',
|
|
'Locale/Maketext/GutsLoader.pm' => [qw( Locale/Maketext/Guts.pm )],
|
|
'Mail/Audit.pm' => 'sub',
|
|
'Math/BigInt.pm' => 'sub',
|
|
'Math/BigFloat.pm' => 'sub',
|
|
'Math/Symbolic.pm' => 'sub',
|
|
'Module/Build.pm' => 'sub',
|
|
'Module/Pluggable.pm' => sub {
|
|
_glob_in_inc('$CurrentPackage/Plugin', 1);
|
|
},
|
|
'MIME/Decoder.pm' => 'sub',
|
|
'Net/DNS/RR.pm' => 'sub',
|
|
'Net/FTP.pm' => 'sub',
|
|
'Net/SSH/Perl.pm' => 'sub',
|
|
'PDF/API2/Resource/Font.pm' => 'sub',
|
|
'PDF/API2/Basic/TTF/Font.pm' => sub {
|
|
_glob_in_inc('PDF/API2/Basic/TTF', 1);
|
|
},
|
|
'PDF/Writer.pm' => 'sub',
|
|
'POE' => [ qw(
|
|
POE/Kernel.pm POE/Session.pm
|
|
) ],
|
|
'POE/Kernel.pm' => [
|
|
map "POE/Resource/$_.pm", qw(
|
|
Aliases Events Extrefs FileHandles
|
|
SIDs Sessions Signals Statistics
|
|
)
|
|
],
|
|
'Parse/AFP.pm' => 'sub',
|
|
'Parse/Binary.pm' => 'sub',
|
|
'Regexp/Common.pm' => 'sub',
|
|
'SerialJunk.pm' => [ qw(
|
|
termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
|
|
) ],
|
|
'SOAP/Lite.pm' => sub {
|
|
(($] >= 5.008 ? ('utf8.pm') : ()), _glob_in_inc('SOAP/Transport', 1));
|
|
},
|
|
'SQL/Parser.pm' => sub {
|
|
_glob_in_inc('SQL/Dialects', 1);
|
|
},
|
|
'SVK/Command.pm' => sub {
|
|
_glob_in_inc('SVK', 1);
|
|
},
|
|
'SVN/Core.pm' => sub {
|
|
_glob_in_inc('SVN', 1),
|
|
map "auto/SVN/$_->{name}", _glob_in_inc('auto/SVN'),
|
|
},
|
|
'Template.pm' => 'sub',
|
|
'Term/ReadLine.pm' => 'sub',
|
|
'Test/Deep.pm' => 'sub',
|
|
'Tk.pm' => sub {
|
|
$SeenTk = 1;
|
|
qw( Tk/FileSelect.pm Encode/Unicode.pm );
|
|
},
|
|
'Tk/Balloon.pm' => [qw( Tk/balArrow.xbm )],
|
|
'Tk/BrowseEntry.pm' => [qw( Tk/cbxarrow.xbm Tk/arrowdownwin.xbm )],
|
|
'Tk/ColorEditor.pm' => [qw( Tk/ColorEdit.xpm )],
|
|
'Tk/DragDrop/Common.pm' => sub {
|
|
_glob_in_inc('Tk/DragDrop', 1),
|
|
},
|
|
'Tk/FBox.pm' => [qw( Tk/folder.xpm Tk/file.xpm )],
|
|
'Tk/Getopt.pm' => [qw( Tk/openfolder.xpm Tk/win.xbm )],
|
|
'Tk/Toplevel.pm' => [qw( Tk/Wm.pm )],
|
|
'URI.pm' => sub {
|
|
grep !/.\b[_A-Z]/, _glob_in_inc('URI', 1);
|
|
},
|
|
'Win32/EventLog.pm' => [qw( Win32/IPC.pm )],
|
|
'Win32/Exe.pm' => 'sub',
|
|
'Win32/TieRegistry.pm' => [qw( Win32API/Registry.pm )],
|
|
'Win32/SystemInfo.pm' => [qw( Win32/cpuspd.dll )],
|
|
'XML/Parser.pm' => sub {
|
|
_glob_in_inc('XML/Parser/Style', 1),
|
|
_glob_in_inc('XML/Parser/Encodings', 1),
|
|
},
|
|
'XML/Parser/Expat.pm' => sub {
|
|
($] >= 5.008) ? ('utf8.pm') : ();
|
|
},
|
|
'XML/SAX.pm' => [qw( XML/SAX/ParserDetails.ini ) ],
|
|
'XMLRPC/Lite.pm' => sub {
|
|
_glob_in_inc('XMLRPC/Transport', 1),;
|
|
},
|
|
'diagnostics.pm' => sub {
|
|
# shamelessly taken and adapted from diagnostics.pm
|
|
use Config;
|
|
my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
|
|
if ($^O eq 'VMS') {
|
|
require VMS::Filespec;
|
|
$privlib = VMS::Filespec::unixify($privlib);
|
|
$archlib = VMS::Filespec::unixify($archlib);
|
|
}
|
|
|
|
for (
|
|
"pod/perldiag.pod",
|
|
"Pod/perldiag.pod",
|
|
"pod/perldiag-$Config{version}.pod",
|
|
"Pod/perldiag-$Config{version}.pod",
|
|
"pods/perldiag.pod",
|
|
"pods/perldiag-$Config{version}.pod",
|
|
) {
|
|
return $_ if _find_in_inc($_);
|
|
}
|
|
|
|
for (
|
|
"$archlib/pods/perldiag.pod",
|
|
"$privlib/pods/perldiag-$Config{version}.pod",
|
|
"$privlib/pods/perldiag.pod",
|
|
) {
|
|
return $_ if -f $_;
|
|
}
|
|
|
|
return 'pod/perldiag.pod';
|
|
},
|
|
'utf8.pm' => [
|
|
'utf8_heavy.pl', do {
|
|
my $dir = 'unicore';
|
|
my @subdirs = qw( To );
|
|
my @files = map "$dir/lib/$_->{name}", _glob_in_inc("$dir/lib");
|
|
|
|
if (@files) {
|
|
# 5.8.x
|
|
push @files, (map "$dir/$_.pl", qw( Exact Canonical ));
|
|
}
|
|
else {
|
|
# 5.6.x
|
|
$dir = 'unicode';
|
|
@files = map "$dir/Is/$_->{name}", _glob_in_inc("$dir/Is")
|
|
or return;
|
|
push @subdirs, 'In';
|
|
}
|
|
|
|
foreach my $subdir (@subdirs) {
|
|
foreach (_glob_in_inc("$dir/$subdir")) {
|
|
push @files, "$dir/$subdir/$_->{name}";
|
|
}
|
|
}
|
|
@files;
|
|
}
|
|
],
|
|
'charnames.pm' => [
|
|
_find_in_inc('unicore/Name.pl') ? 'unicore/Name.pl' : 'unicode/Name.pl'
|
|
],
|
|
);
|
|
|
|
# }}}
|
|
|
|
my $Keys = 'files|keys|recurse|rv|skip|first|execute|compile';
|
|
sub scan_deps {
|
|
my %args = (
|
|
rv => {},
|
|
(@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
|
|
);
|
|
|
|
scan_deps_static(\%args);
|
|
|
|
if ($args{execute} or $args{compile}) {
|
|
scan_deps_runtime(
|
|
rv => $args{rv},
|
|
files => $args{files},
|
|
execute => $args{execute},
|
|
compile => $args{compile},
|
|
skip => $args{skip}
|
|
);
|
|
}
|
|
|
|
return ($args{rv});
|
|
}
|
|
|
|
sub scan_deps_static {
|
|
my ($args) = @_;
|
|
my ($files, $keys, $recurse, $rv, $skip, $first, $execute, $compile) =
|
|
@$args{qw( files keys recurse rv skip first execute compile )};
|
|
|
|
$rv ||= {};
|
|
$skip ||= {};
|
|
|
|
foreach my $file (@{$files}) {
|
|
my $key = shift @{$keys};
|
|
next if $skip->{$file}++;
|
|
next if is_insensitive_fs()
|
|
and $file ne lc($file) and $skip->{lc($file)}++;
|
|
|
|
local *FH;
|
|
open FH, $file or die "Cannot open $file: $!";
|
|
|
|
$SeenTk = 0;
|
|
|
|
# Line-by-line scanning
|
|
LINE:
|
|
while (<FH>) {
|
|
chomp(my $line = $_);
|
|
foreach my $pm (scan_line($line)) {
|
|
last LINE if $pm eq '__END__';
|
|
|
|
if ($pm eq '__POD__') {
|
|
while (<FH>) { last if (/^=cut/) }
|
|
next LINE;
|
|
}
|
|
|
|
$pm = 'CGI/Apache.pm' if /^Apache(?:\.pm)$/;
|
|
|
|
add_deps(
|
|
used_by => $key,
|
|
rv => $rv,
|
|
modules => [$pm],
|
|
skip => $skip
|
|
);
|
|
|
|
my $preload = $Preload{$pm} or next;
|
|
if ($preload eq 'sub') {
|
|
$pm =~ s/\.p[mh]$//i;
|
|
$preload = [ _glob_in_inc($pm, 1) ];
|
|
}
|
|
elsif (UNIVERSAL::isa($preload, 'CODE')) {
|
|
$preload = [ $preload->($pm) ];
|
|
}
|
|
|
|
add_deps(
|
|
used_by => $key,
|
|
rv => $rv,
|
|
modules => $preload,
|
|
skip => $skip
|
|
);
|
|
}
|
|
}
|
|
close FH;
|
|
|
|
# }}}
|
|
}
|
|
|
|
# Top-level recursion handling {{{
|
|
while ($recurse) {
|
|
my $count = keys %$rv;
|
|
my @files = sort grep -T $_->{file}, values %$rv;
|
|
scan_deps_static({
|
|
files => [ map $_->{file}, @files ],
|
|
keys => [ map $_->{key}, @files ],
|
|
rv => $rv,
|
|
skip => $skip,
|
|
recurse => 0,
|
|
}) or ($args->{_deep} and return);
|
|
last if $count == keys %$rv;
|
|
}
|
|
|
|
# }}}
|
|
|
|
return $rv;
|
|
}
|
|
|
|
sub scan_deps_runtime {
|
|
my %args = (
|
|
perl => $^X,
|
|
rv => {},
|
|
(@_ and $_[0] =~ /^(?:$Keys)$/o) ? @_ : (files => [@_], recurse => 1)
|
|
);
|
|
my ($files, $rv, $execute, $compile, $skip, $perl) =
|
|
@args{qw( files rv execute compile skip perl )};
|
|
|
|
$files = (ref($files)) ? $files : [$files];
|
|
|
|
my ($inchash, $incarray, $dl_shared_objects) = ({}, [], []);
|
|
if ($compile) {
|
|
my $file;
|
|
|
|
foreach $file (@$files) {
|
|
($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
|
|
_compile($perl, $file, $inchash, $dl_shared_objects, $incarray);
|
|
|
|
my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
|
|
_merge_rv($rv_sub, $rv);
|
|
}
|
|
}
|
|
elsif ($execute) {
|
|
my $excarray = (ref($execute)) ? $execute : [@$files];
|
|
my $exc;
|
|
my $first_flag = 1;
|
|
foreach $exc (@$excarray) {
|
|
($inchash, $dl_shared_objects, $incarray) = ({}, [], []);
|
|
_execute(
|
|
$perl, $exc, $inchash, $dl_shared_objects, $incarray,
|
|
$first_flag
|
|
);
|
|
$first_flag = 0;
|
|
}
|
|
|
|
my $rv_sub = _make_rv($inchash, $dl_shared_objects, $incarray);
|
|
_merge_rv($rv_sub, $rv);
|
|
}
|
|
|
|
return ($rv);
|
|
}
|
|
|
|
sub scan_line {
|
|
my $line = shift;
|
|
my %found;
|
|
|
|
return '__END__' if $line =~ /^__(?:END|DATA)__$/;
|
|
return '__POD__' if $line =~ /^=\w/;
|
|
|
|
$line =~ s/\s*#.*$//;
|
|
$line =~ s/[\\\/]+/\//g;
|
|
|
|
foreach (split(/;/, $line)) {
|
|
if (/^\s*package\s+(\w+)/) {
|
|
$CurrentPackage = $1;
|
|
$CurrentPackage =~ s{::}{/}g;
|
|
return;
|
|
}
|
|
return if /^\s*(use|require)\s+[\d\._]+/;
|
|
if (my ($autouse) = /^\s*use\s+autouse\s+(["'].*?["']|\w+)/)
|
|
{
|
|
$autouse =~ s/["']//g;
|
|
$autouse =~ s{::}{/}g;
|
|
return ("autouse.pm", "$autouse.pm");
|
|
}
|
|
|
|
if (my ($libs) = /\b(?:use\s+lib\s+|(?:unshift|push)\W+\@INC\W+)(.+)/)
|
|
{
|
|
my $archname =
|
|
defined($Config{archname}) ? $Config{archname} : '';
|
|
my $ver = defined($Config{version}) ? $Config{version} : '';
|
|
foreach (grep(/\w/, split(/["';() ]/, $libs))) {
|
|
unshift(@INC, "$_/$ver") if -d "$_/$ver";
|
|
unshift(@INC, "$_/$archname") if -d "$_/$archname";
|
|
unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname";
|
|
}
|
|
next;
|
|
}
|
|
|
|
$found{$_}++ for scan_chunk($_);
|
|
}
|
|
|
|
return sort keys %found;
|
|
}
|
|
|
|
sub scan_chunk {
|
|
my $chunk = shift;
|
|
|
|
# Module name extraction heuristics {{{
|
|
my $module = eval {
|
|
$_ = $chunk;
|
|
|
|
return [ 'base.pm',
|
|
map { s{::}{/}g; "$_.pm" }
|
|
grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
|
|
if /^\s* use \s+ base \s+ (.*)/sx;
|
|
|
|
return [ 'Class/Autouse.pm',
|
|
map { s{::}{/}g; "$_.pm" }
|
|
grep { length and !/^:|^q[qw]?$/ } split(/[^\w:]+/, $1) ]
|
|
if /^\s* use \s+ Class::Autouse \s+ (.*)/sx
|
|
or /^\s* Class::Autouse \s* -> \s* autouse \s* (.*)/sx;
|
|
|
|
return [ 'POE.pm',
|
|
map { s{::}{/}g; "POE/$_.pm" }
|
|
grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1) ]
|
|
if /^\s* use \s+ POE \s+ (.*)/sx;
|
|
|
|
return [ 'encoding.pm',
|
|
map { _find_encoding($_) }
|
|
grep { length and !/^q[qw]?$/ } split(/[^\w:-]+/, $1) ]
|
|
if /^\s* use \s+ encoding \s+ (.*)/sx;
|
|
|
|
return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']+)/;
|
|
return $1
|
|
if /(?:^|\s)(?:use|no|require)\s+\(\s*([\w:\.\-\\\/\"\']+)\s*\)/;
|
|
|
|
if ( s/(?:^|\s)eval\s+\"([^\"]+)\"/$1/
|
|
or s/(?:^|\s)eval\s*\(\s*\"([^\"]+)\"\s*\)/$1/)
|
|
{
|
|
return $1 if /(?:^|\s)(?:use|no|require)\s+([\w:\.\-\\\/\"\']*)/;
|
|
}
|
|
|
|
return "File/Glob.pm" if /<[^>]*[^\$\w>][^>]*>/;
|
|
return "DBD/$1.pm" if /\b[Dd][Bb][Ii]:(\w+):/;
|
|
if (/(?:(:encoding)|\b(?:en|de)code)\(\s*['"]?([-\w]+)/) {
|
|
my $mod = _find_encoding($2);
|
|
return [ 'PerlIO.pm', $mod ] if $1 and $mod;
|
|
return $mod if $mod;
|
|
}
|
|
return $1 if /(?:^|\s)(?:do|require)\s+[^"]*"(.*?)"/;
|
|
return $1 if /(?:^|\s)(?:do|require)\s+[^']*'(.*?)'/;
|
|
return $1 if /[^\$]\b([\w:]+)->\w/ and $1 ne 'Tk';
|
|
return $1 if /\b(\w[\w:]*)::\w+\(/;
|
|
|
|
if ($SeenTk) {
|
|
my @modules;
|
|
while (/->\s*([A-Z]\w+)/g) {
|
|
push @modules, "Tk/$1.pm";
|
|
}
|
|
while (/->\s*Scrolled\W+([A-Z]\w+)/g) {
|
|
push @modules, "Tk/$1.pm";
|
|
push @modules, "Tk/Scrollbar.pm";
|
|
}
|
|
return \@modules;
|
|
}
|
|
return;
|
|
};
|
|
|
|
# }}}
|
|
|
|
return unless defined($module);
|
|
return wantarray ? @$module : $module->[0] if ref($module);
|
|
|
|
$module =~ s/^['"]//;
|
|
return unless $module =~ /^\w/;
|
|
|
|
$module =~ s/\W+$//;
|
|
$module =~ s/::/\//g;
|
|
return if $module =~ /^(?:[\d\._]+|'.*[^']|".*[^"])$/;
|
|
|
|
$module .= ".pm" unless $module =~ /\./;
|
|
return $module;
|
|
}
|
|
|
|
sub _find_encoding {
|
|
return unless $] >= 5.008 and eval { require Encode; %Encode::ExtModule };
|
|
|
|
my $mod = $Encode::ExtModule{ Encode::find_encoding($_[0])->name }
|
|
or return;
|
|
$mod =~ s{::}{/}g;
|
|
return "$mod.pm";
|
|
}
|
|
|
|
sub _add_info {
|
|
my ($rv, $module, $file, $used_by, $type) = @_;
|
|
return unless defined($module) and defined($file);
|
|
|
|
$rv->{$module} ||= {
|
|
file => $file,
|
|
key => $module,
|
|
type => $type,
|
|
};
|
|
|
|
push @{ $rv->{$module}{used_by} }, $used_by
|
|
if defined($used_by)
|
|
and $used_by ne $module
|
|
and !grep { $_ eq $used_by } @{ $rv->{$module}{used_by} };
|
|
}
|
|
|
|
sub add_deps {
|
|
my %args =
|
|
((@_ and $_[0] =~ /^(?:modules|rv|used_by)$/)
|
|
? @_
|
|
: (rv => (ref($_[0]) ? shift(@_) : undef), modules => [@_]));
|
|
|
|
my $rv = $args{rv} || {};
|
|
my $skip = $args{skip} || {};
|
|
my $used_by = $args{used_by};
|
|
|
|
foreach my $module (@{ $args{modules} }) {
|
|
if (exists $rv->{$module}) {
|
|
_add_info($rv, undef, undef, $used_by, undef);
|
|
next;
|
|
}
|
|
|
|
my $file = _find_in_inc($module) or next;
|
|
next if $skip->{$file};
|
|
next if is_insensitive_fs() and $skip->{lc($file)};
|
|
|
|
my $type = 'module';
|
|
$type = 'data' unless $file =~ /\.p[mh]$/i;
|
|
_add_info($rv, $module, $file, $used_by, $type);
|
|
|
|
if ($module =~ /(.*?([^\/]*))\.p[mh]$/i) {
|
|
my ($path, $basename) = ($1, $2);
|
|
|
|
foreach (_glob_in_inc("auto/$path")) {
|
|
next if $skip->{$_->{file}};
|
|
next if is_insensitive_fs() and $skip->{lc($_->{file})};
|
|
next if $_->{file} =~ m{\bauto/$path/.*/}; # weed out subdirs
|
|
next if $_->{name} =~ m/(?:^|\/)\.(?:exists|packlist)$/;
|
|
my $ext = lc($1) if $_->{name} =~ /(\.[^.]+)$/;
|
|
next if $ext eq lc(lib_ext());
|
|
my $type = 'shared' if $ext eq lc(dl_ext());
|
|
$type = 'autoload' if $ext eq '.ix' or $ext eq '.al';
|
|
$type ||= 'data';
|
|
|
|
_add_info($rv, "auto/$path/$_->{name}", $_->{file}, $module,
|
|
$type);
|
|
}
|
|
}
|
|
}
|
|
|
|
return $rv;
|
|
}
|
|
|
|
sub _find_in_inc {
|
|
my $file = shift;
|
|
|
|
# absolute file names
|
|
return $file if -f $file;
|
|
|
|
foreach my $dir (grep !/\bBSDPAN\b/, @INC) {
|
|
return "$dir/$file" if -f "$dir/$file";
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _glob_in_inc {
|
|
my $subdir = shift;
|
|
my $pm_only = shift;
|
|
my @files;
|
|
|
|
require File::Find;
|
|
|
|
$subdir =~ s/\$CurrentPackage/$CurrentPackage/;
|
|
|
|
foreach my $dir (map "$_/$subdir", grep !/\bBSDPAN\b/, @INC) {
|
|
next unless -d $dir;
|
|
File::Find::find(
|
|
sub {
|
|
my $name = $File::Find::name;
|
|
$name =~ s!^\Q$dir\E/!!;
|
|
return if $pm_only and lc($name) !~ /\.p[mh]$/i;
|
|
push @files, $pm_only
|
|
? "$subdir/$name"
|
|
: { file => $File::Find::name,
|
|
name => $name,
|
|
}
|
|
if -f;
|
|
},
|
|
$dir
|
|
);
|
|
}
|
|
|
|
return @files;
|
|
}
|
|
|
|
# App::Packer compatibility functions
|
|
|
|
sub new {
|
|
my ($class, $self) = @_;
|
|
return bless($self ||= {}, $class);
|
|
}
|
|
|
|
sub set_file {
|
|
my $self = shift;
|
|
foreach my $script (@_) {
|
|
my $basename = $script;
|
|
$basename =~ s/.*\///;
|
|
$self->{main} = {
|
|
key => $basename,
|
|
file => $script,
|
|
};
|
|
}
|
|
}
|
|
|
|
sub set_options {
|
|
my $self = shift;
|
|
my %args = @_;
|
|
foreach my $module (@{ $args{add_modules} }) {
|
|
$module =~ s/::/\//g;
|
|
$module .= '.pm' unless $module =~ /\.p[mh]$/i;
|
|
my $file = _find_in_inc($module) or next;
|
|
$self->{files}{$module} = $file;
|
|
}
|
|
}
|
|
|
|
sub calculate_info {
|
|
my $self = shift;
|
|
my $rv = scan_deps(
|
|
keys => [ $self->{main}{key}, sort keys %{ $self->{files} }, ],
|
|
files => [ $self->{main}{file},
|
|
map { $self->{files}{$_} } sort keys %{ $self->{files} },
|
|
],
|
|
recurse => 1,
|
|
);
|
|
|
|
my $info = {
|
|
main => { file => $self->{main}{file},
|
|
store_as => $self->{main}{key},
|
|
},
|
|
};
|
|
|
|
my %cache = ($self->{main}{key} => $info->{main});
|
|
foreach my $key (sort keys %{ $self->{files} }) {
|
|
my $file = $self->{files}{$key};
|
|
|
|
$cache{$key} = $info->{modules}{$key} = {
|
|
file => $file,
|
|
store_as => $key,
|
|
used_by => [ $self->{main}{key} ],
|
|
};
|
|
}
|
|
|
|
foreach my $key (sort keys %{$rv}) {
|
|
my $val = $rv->{$key};
|
|
if ($cache{ $val->{key} }) {
|
|
push @{ $info->{ $val->{type} }->{ $val->{key} }->{used_by} },
|
|
@{ $val->{used_by} };
|
|
}
|
|
else {
|
|
$cache{ $val->{key} } = $info->{ $val->{type} }->{ $val->{key} } =
|
|
{ file => $val->{file},
|
|
store_as => $val->{key},
|
|
used_by => $val->{used_by},
|
|
};
|
|
}
|
|
}
|
|
|
|
$self->{info} = { main => $info->{main} };
|
|
|
|
foreach my $type (sort keys %{$info}) {
|
|
next if $type eq 'main';
|
|
|
|
my @val;
|
|
if (UNIVERSAL::isa($info->{$type}, 'HASH')) {
|
|
foreach my $val (sort values %{ $info->{$type} }) {
|
|
@{ $val->{used_by} } = map $cache{$_} || "!!$_!!",
|
|
@{ $val->{used_by} };
|
|
push @val, $val;
|
|
}
|
|
}
|
|
|
|
$type = 'modules' if $type eq 'module';
|
|
$self->{info}{$type} = \@val;
|
|
}
|
|
}
|
|
|
|
sub get_files {
|
|
my $self = shift;
|
|
return $self->{info};
|
|
}
|
|
|
|
# scan_deps_runtime utility functions
|
|
|
|
sub _compile {
|
|
my ($perl, $file, $inchash, $dl_shared_objects, $incarray) = @_;
|
|
|
|
my ($fhout, $fname) = File::Temp::tempfile("XXXXXX");
|
|
my $fhin = FileHandle->new($file) or die "Couldn't open $file\n";
|
|
|
|
my $line = do { local $/; <$fhin> };
|
|
$line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
|
|
$line =~ s/^(.*?)((?:[\r\n]+__(?:DATA|END)__[\r\n]+)|$)/
|
|
use Module::ScanDeps::DataFeed '$fname.out';
|
|
sub {
|
|
$1
|
|
}
|
|
$2/s;
|
|
$fhout->print($line);
|
|
$fhout->close;
|
|
$fhin->close;
|
|
|
|
system($perl, $fname);
|
|
|
|
_extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
|
|
unlink("$fname");
|
|
unlink("$fname.out");
|
|
}
|
|
|
|
sub _execute {
|
|
my ($perl, $file, $inchash, $dl_shared_objects, $incarray, $firstflag) = @_;
|
|
|
|
$DB::single = $DB::single = 1;
|
|
my ($fhout, $fname) = File::Temp::tempfile("XXXXXX");
|
|
$fname = _abs_path($fname);
|
|
my $fhin = FileHandle->new($file) or die "Couldn't open $file";
|
|
|
|
my $line = do { local $/; <$fhin> };
|
|
$line =~ s/use Module::ScanDeps::DataFeed.*?\n//sg;
|
|
$line = "use Module::ScanDeps::DataFeed '$fname.out';\n" . $line;
|
|
$fhout->print($line);
|
|
$fhout->close;
|
|
$fhin->close;
|
|
|
|
File::Path::rmtree( ['_Inline'], 0, 1); # XXX hack
|
|
system($perl, $fname) == 0 or die "SYSTEM ERROR in executing $file: $?";
|
|
|
|
_extract_info("$fname.out", $inchash, $dl_shared_objects, $incarray);
|
|
unlink("$fname");
|
|
unlink("$fname.out");
|
|
}
|
|
|
|
sub _make_rv {
|
|
my ($inchash, $dl_shared_objects, $inc_array) = @_;
|
|
|
|
my $rv = {};
|
|
my @newinc = map(quotemeta($_), @$inc_array);
|
|
my $inc = join('|', sort { length($b) <=> length($a) } @newinc);
|
|
|
|
require File::Spec;
|
|
|
|
my $key;
|
|
foreach $key (keys(%$inchash)) {
|
|
my $newkey = $key;
|
|
$newkey =~ s"^(?:(?:$inc)/?)""sg if File::Spec->file_name_is_absolute($newkey);
|
|
|
|
$rv->{$newkey} = {
|
|
'used_by' => [],
|
|
'file' => $inchash->{$key},
|
|
'type' => _gettype($inchash->{$key}),
|
|
'key' => $key
|
|
};
|
|
}
|
|
|
|
my $dl_file;
|
|
foreach $dl_file (@$dl_shared_objects) {
|
|
my $key = $dl_file;
|
|
$key =~ s"^(?:(?:$inc)/?)""s;
|
|
|
|
$rv->{$key} = {
|
|
'used_by' => [],
|
|
'file' => $dl_file,
|
|
'type' => 'shared',
|
|
'key' => $key
|
|
};
|
|
}
|
|
|
|
return $rv;
|
|
}
|
|
|
|
sub _extract_info {
|
|
my ($fname, $inchash, $dl_shared_objects, $incarray) = @_;
|
|
|
|
use vars qw(%inchash @dl_shared_objects @incarray);
|
|
my $fh = FileHandle->new($fname) or die "Couldn't open $fname";
|
|
my $line = do { local $/; <$fh> };
|
|
$fh->close;
|
|
|
|
eval $line;
|
|
|
|
$inchash->{$_} = $inchash{$_} for keys %inchash;
|
|
@$dl_shared_objects = @dl_shared_objects;
|
|
@$incarray = @incarray;
|
|
}
|
|
|
|
sub _gettype {
|
|
my $name = shift;
|
|
my $dlext = quotemeta(dl_ext());
|
|
|
|
return 'autoload' if $name =~ /(?:\.ix|\.al|\.bs)$/i;
|
|
return 'module' if $name =~ /\.p[mh]$/i;
|
|
return 'shared' if $name =~ /\.$dlext$/i;
|
|
return 'data';
|
|
}
|
|
|
|
sub _merge_rv {
|
|
my ($rv_sub, $rv) = @_;
|
|
|
|
my $key;
|
|
foreach $key (keys(%$rv_sub)) {
|
|
my %mark;
|
|
if ($rv->{$key} and _not_dup($key, $rv, $rv_sub)) {
|
|
warn "Different modules for file '$key' were found.\n"
|
|
. " -> Using '" . _abs_path($rv_sub->{$key}{file}) . "'.\n"
|
|
. " -> Ignoring '" . _abs_path($rv->{$key}{file}) . "'.\n";
|
|
$rv->{$key}{used_by} = [
|
|
grep (!$mark{$_}++,
|
|
@{ $rv->{$key}{used_by} },
|
|
@{ $rv_sub->{$key}{used_by} })
|
|
];
|
|
@{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
|
|
$rv->{$key}{file} = $rv_sub->{$key}{file};
|
|
}
|
|
elsif ($rv->{$key}) {
|
|
$rv->{$key}{used_by} = [
|
|
grep (!$mark{$_}++,
|
|
@{ $rv->{$key}{used_by} },
|
|
@{ $rv_sub->{$key}{used_by} })
|
|
];
|
|
@{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
|
|
}
|
|
else {
|
|
$rv->{$key} = {
|
|
used_by => [ @{ $rv_sub->{$key}{used_by} } ],
|
|
file => $rv_sub->{$key}{file},
|
|
key => $rv_sub->{$key}{key},
|
|
type => $rv_sub->{$key}{type}
|
|
};
|
|
|
|
@{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
|
|
}
|
|
}
|
|
}
|
|
|
|
sub _not_dup {
|
|
my ($key, $rv1, $rv2) = @_;
|
|
(_abs_path($rv1->{$key}{file}) ne _abs_path($rv2->{$key}{file}));
|
|
}
|
|
|
|
sub _abs_path {
|
|
return join(
|
|
'/',
|
|
Cwd::abs_path(File::Basename::dirname($_[0])),
|
|
File::Basename::basename($_[0]),
|
|
);
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<scandeps.pl> is a bundled utility that writes C<PREREQ_PM> section
|
|
for a number of files.
|
|
|
|
An application of B<Module::ScanDeps> is to generate executables from
|
|
scripts that contains prerequisite modules; this module supports two
|
|
such projects, L<PAR> and L<App::Packer>. Please see their respective
|
|
documentations on CPAN for further information.
|
|
|
|
=head1 AUTHORS
|
|
|
|
Audrey Tang E<lt>autrijus@autrijus.orgE<gt>
|
|
|
|
Parts of heuristics were deduced from:
|
|
|
|
=over 4
|
|
|
|
=item *
|
|
|
|
B<PerlApp> by ActiveState Tools Corp L<http://www.activestate.com/>
|
|
|
|
=item *
|
|
|
|
B<Perl2Exe> by IndigoStar, Inc L<http://www.indigostar.com/>
|
|
|
|
=back
|
|
|
|
The B<scan_deps_runtime> function is contributed by Edward S. Peschko.
|
|
|
|
L<http://par.perl.org/> is the official website for this module. You
|
|
can write to the mailing list at E<lt>par@perl.orgE<gt>, or send an empty
|
|
mail to E<lt>par-subscribe@perl.orgE<gt> to participate in the discussion.
|
|
|
|
Please submit bug reports to E<lt>bug-Module-ScanDeps@rt.cpan.orgE<gt>.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2002, 2003, 2004, 2005, 2006 by
|
|
Audrey Tang E<lt>autrijus@autrijus.orgE<gt>.
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the same terms as Perl itself.
|
|
|
|
See L<http://www.perl.com/perl/misc/Artistic.html>
|
|
|
|
=cut
|