summaryrefslogtreecommitdiff
path: root/scripts/perldeps.pl
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/perldeps.pl')
-rwxr-xr-xscripts/perldeps.pl1116
1 files changed, 0 insertions, 1116 deletions
diff --git a/scripts/perldeps.pl b/scripts/perldeps.pl
deleted file mode 100755
index bffad674a..000000000
--- a/scripts/perldeps.pl
+++ /dev/null
@@ -1,1116 +0,0 @@
-#!/usr/bin/perl -Tw
-#
-# perldeps.pl -- Analyze dependencies of Perl packages
-#
-# Michael Jennings
-# 7 November 2005
-#
-# $Id: perldeps.pl,v 1.6 2006/04/04 20:12:03 mej Exp $
-#
-
-use strict;
-use Config;
-use File::Basename;
-use File::Find;
-use Getopt::Long;
-use POSIX;
-
-############### Debugging stolen from Mezzanine::Util ###############
-my $DEBUG = 0;
-
-# Debugging output
-sub
-dprintf(@)
-{
- my ($f, $l, $s, $format);
- my @params = @_;
-
- return if (! $DEBUG);
- $format = shift @params;
- if (!scalar(@params)) {
- return dprint($format);
- }
- (undef, undef, undef, $s) = caller(1);
- if (!defined($s)) {
- $s = "MAIN";
- }
- (undef, $f, $l) = caller(0);
- $f =~ s/^.*\/([^\/]+)$/$1/;
- $s =~ s/^\w+:://g;
- $s .= "()" if ($s =~ /^\w+$/);
- $f = "" if (!defined($f));
- $l = "" if (!defined($l));
- $format = "" if (!defined($format));
- for (my $i = 0; $i < scalar(@params); $i++) {
- if (!defined($params[$i])) {
- $params[$i] = "<undef>";
- }
- }
- printf("[$f/$l/$s] $format", @params);
-}
-
-sub
-dprint(@)
-{
- my ($f, $l, $s);
- my @params = @_;
-
- return if (! $DEBUG);
- (undef, undef, undef, $s) = caller(1);
- if (!defined($s)) {
- $s = "MAIN";
- }
- (undef, $f, $l) = caller(0);
- $f =~ s/^.*\/([^\/]+)$/$1/;
- $s =~ s/\w+:://g;
- $s .= "()" if ($s =~ /^\w+$/);
- $f = "" if (!defined($f));
- $l = "" if (!defined($l));
- $s = "" if (!defined($s));
- for (my $i = 0; $i < scalar(@params); $i++) {
- if (!defined($params[$i])) {
- $params[$i] = "<undef>";
- }
- }
- print "[$f/$l/$s] ", @params;
-}
-
-############### Module::ScanDeps Code ###############
-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
-);
-
-my $CurrentPackage = '';
-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/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 (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({
- "wanted" => 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;
- },
- "untaint" => 1,
- "untaint_skip" => 1,
- "untaint_pattern" => qr|^([-+@\w./]+)$|
- }, $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 $fname = File::Temp::mktemp("$file.XXXXXX");
- my $fhin = FileHandle->new($file) or die "Couldn't open $file\n";
- my $fhout = FileHandle->new("> $fname") or die "Couldn't open $fname\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 $fname = _abs_path(File::Temp::mktemp("$file.XXXXXX"));
- my $fhin = FileHandle->new($file) or die "Couldn't open $file";
- my $fhout = FileHandle->new("> $fname") or die "Couldn't open $fname";
-
- 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]),
- );
-}
-
-#####################################################
-### Actual perldeps.pl code starts here.
-
-# Print usage information
-sub
-print_usage_info($)
-{
- my $code = shift || 0;
- my ($leader, $underbar);
-
- print "\n";
- $leader = "$0 Usage Information";
- $underbar = $leader;
- $underbar =~ s/./-/g;
- print "$leader\n$underbar\n";
- print "\n";
- print " Syntax: $0 [ options ] [ path(s)/file(s) ]\n";
- print "\n";
- print " -h --help Show this usage information\n";
- print " -v --version Show version and copyright\n";
- print " -d --debug Turn on debugging\n";
- print " -p --provides Find things provided by path(s)/file(s)\n";
- print " -r --requires Find things required by path(s)/file(s)\n";
- #print " \n";
- print "\nNOTE: Path(s)/file(s) can also be specified on STDIN. Default is \@INC.\n\n";
- exit($code);
-}
-
-# Locate perl modules (*.pm) in given locations.
-sub
-find_perl_modules(@)
-{
- my @locations = @_;
- my %modules;
-
- foreach my $loc (@locations) {
- if (-f $loc) {
- # It's a file. Assume it's a Perl module.
- #print "Found module: $loc.\n";
- $modules{$loc} = 1;
- } elsif (-d $loc) {
- my @tmp;
-
- # Recurse the directory tree looking for all modules inside it.
- &File::Find::find({
- "wanted" => sub {
- if ((-s _) && (substr($File::Find::fullname, -3, 3) eq ".pm")) {
- push @tmp, $File::Find::fullname;
- }
- },
- "follow_fast" => 1,
- "no_chdir" => 1,
- "untaint" => 1,
- "untaint_skip" => 1,
- "untaint_pattern" => qr|^([-+@\w./]+)$|
- }, $loc);
-
- # @tmp is now a list with all non-empty *.pm files in and under $loc.
- # Untaint and save in %modules hash.
- foreach my $module (@tmp) {
- if ($module =~ /^([-+@\w.\/]+)$/) {
- $modules{$1} = 1;
- #print "Found module: $1\n";
- }
- }
- } else {
- # Something wicked this way comes.
- print STDERR "$0: Error: Don't know what to do with location \"$loc\"\n";
- }
- }
- return keys(%modules);
-}
-
-# Generate an RPM-style "Provides:" list for the given modules.
-sub
-find_provides(@)
-{
- my @modules = @_;
- my @prov;
-
- foreach my $mod (@modules) {
- my (@contents, @pkgs);
- my $mod_path;
- local *MOD;
-
- $mod_path = dirname($mod);
- if (!open(MOD, $mod)) {
- warn "Unable to read module $mod -- $!\n";
- next;
- }
- @contents = <MOD>;
- if (!close(MOD)) {
- warn "Unable to close module $mod -- $!\n";
- }
-
- if (!scalar(grep { $_ eq $mod_path } @INC)) {
- push @INC, $mod_path;
- }
- foreach my $line (grep { $_ =~ /^\s*package\s+/ } @contents) {
- if ($line =~ /^\s*package\s+([^\;\s]+)\s*\;/) {
- push @pkgs, $1;
- }
- }
-
- # Now we have a list of packages. Load up the modules and get their versions.
- foreach my $pkg (@pkgs) {
- my $ret;
- local ($SIG{"__WARN__"}, $SIG{"__DIE__"});
-
- # Make sure eval() can't display warnings/errors.
- $SIG{"__DIE__"} = $SIG{"__WARN__"} = sub {0;};
- $ret = eval("no strict ('vars', 'subs', 'refs'); use $pkg (); return $pkg->VERSION || 0.0;");
- if ($@) {
- dprint "Unable to parse version number from $pkg -- $@. Assuming 0.\n";
- $ret = 0;
- }
-
- if (! $ret) {
- $ret = 0;
- }
- push @prov, "perl($pkg) = $ret";
- }
- }
- printf("Provides: %s\n", join(", ", sort(@prov)));
-}
-
-# Generate an RPM-style "Requires:" list for the given modules.
-sub
-find_requires(@)
-{
- my @modules = @_;
- my @reqs;
- my $reqs;
-
- $reqs = &scan_deps("files" => \@modules, "recurse" => 0);
- foreach my $key (grep { $reqs->{$_}{"type"} eq "module" } sort(keys(%{$reqs}))) {
- if (substr($key, -3, 3) eq ".pm") {
- $key = substr($key, 0, -3);
- }
- $key =~ s!/!::!g;
- push @reqs, "perl($key)";
- }
- printf("Requires: %s\n", join(", ", @reqs));
-}
-
-sub
-main()
-{
- my $VERSION = '1.0';
- my (@locations, @modules);
- my %OPTION;
-
- # For taint checks
- delete @ENV{("IFS", "CDPATH", "ENV", "BASH_ENV")};
- $ENV{"PATH"} = "/bin:/usr/bin:/sbin:/usr/sbin:/etc:/usr/ucb";
- foreach my $shell ("/bin/bash", "/usr/bin/ksh", "/bin/ksh", "/bin/sh", "/sbin/sh") {
- if (-f $shell) {
- $ENV{"SHELL"} = $shell;
- last;
- }
- }
-
- $ENV{"LANG"} = "C" if (! $ENV{"LANG"});
- umask 022;
- select STDERR; $| = 1;
- select STDOUT; $| = 1;
-
- Getopt::Long::Configure("no_getopt_compat", "bundling", "no_ignore_case");
- Getopt::Long::GetOptions(\%OPTION, "debug|d!", "help|h", "version|v", "provides|p", "requires|r");
-
- # Post-parse the options stuff
- select STDOUT; $| = 1;
- if ($OPTION{"version"}) {
- # Do not edit this variable. It is updated automatically by CVS when you commit
- my $rcs_info = 'CVS Revision $Revision: 1.6 $ created on $Date: 2006/04/04 20:12:03 $ by $Author: mej $ ';
-
- $rcs_info =~ s/\$\s*Revision: (\S+) \$/$1/;
- $rcs_info =~ s/\$\s*Date: (\S+) (\S+) \$/$1 at $2/;
- $rcs_info =~ s/\$\s*Author: (\S+) \$ /$1/;
- print "\n";
- print "perldeps.pl $VERSION by Michael Jennings <mej\@eterm.org>\n";
- print "Copyright (c) 2005-2006, Michael Jennings\n";
- print " ($rcs_info)\n";
- print "\n";
- return 0;
- } elsif ($OPTION{"help"}) {
- &print_usage_info(0); # Never returns
- }
-
- push @locations, @ARGV;
- if (!scalar(@ARGV) && !(-t STDIN)) {
- @locations = <STDIN>;
- }
- if (!scalar(@locations)) {
- @locations = @INC;
- }
-
- if (!($OPTION{"provides"} || $OPTION{"requires"})) {
- &print_usage_info(-1); # Never returns
- }
-
- # Catch bogus warning messages like "A thread exited while 2 threads were running"
- $SIG{"__DIE__"} = $SIG{"__WARN__"} = sub {0;};
-
- @modules = &find_perl_modules(@locations);
- if ($OPTION{"provides"}) {
- &find_provides(@modules);
- }
- if ($OPTION{"requires"}) {
- &find_requires(@modules);
- }
- return 0;
-}
-
-exit &main();
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 13:52:07 +0000