ok
Direktori : /proc/self/root/proc/self/root/lib/rpm/ |
Current File : //proc/self/root/proc/self/root/lib/rpm/perldeps.pl |
#!/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();