—
—

              
package Module::ScanDeps;
use 5.004;
use strict;
use vars qw( $VERSION @EXPORT @EXPORT_OK $CurrentPackage );
$VERSION   = '0.54';
@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;
HideShow 152 lines of Pod
=head1 NAME
Module::ScanDeps - Recursively scan Perl code for dependencies
=head1 VERSION
This document describes version 0.54 of Module::ScanDeps, released
January 11, 2005.
=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',
    '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',
    'SOAP/Lite.pm'                  => sub {
        (($] >= 5.008 ? ('utf8.pm') : ()), _glob_in_inc('SOAP/Transport', 1));
    },
    'SQL/Parser.pm' => sub {
        _glob_in_inc('SQL/Dialects', 1);
    },
    'SVN/Core.pm' => sub {
        _glob_in_inc('SVN', 1),
        map "auto/SVN/$_->{name}", _glob_in_inc('auto/SVN'),
    },
    'SVK/Command.pm' => sub {
        _glob_in_inc('SVK', 1);
    },
    'SerialJunk.pm' => [ qw(
        termios.ph asm/termios.ph sys/termiox.ph sys/termios.ph sys/ttycom.ph
    ) ],
    'Template.pm'      => 'sub',
    'Term/ReadLine.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/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 {
        _find_in_inc('Pod/perldiag.pod')
          ? 'Pod/perldiag.pl'
          : '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 ( /^\s*use\s+autouse\s+[\"\']([^"\']+).*/ )
        {
            s/^\s*use\s+autouse\s+[\"\']([^"\']+).*/$1/;
            return "$_.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} }) {
        next if exists $rv->{$module};
        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;
    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" .
                 "(using the version) after the '=>': ".
                 "$rv->{$key}{file} => $rv_sub->{$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__
HideShow 48 lines of Pod
=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