home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / boot / i386 / rescue / usr / lib / rpm / perldeps.pl < prev    next >
Encoding:
Perl Script  |  2006-11-29  |  8.6 KB  |  389 lines
  1. #!/usr/bin/perl -w
  2. use strict;
  3. use 5.006001;
  4.  
  5. use Getopt::Long;
  6. my ($show_provides, $show_requires, $verbose, @ignores);
  7.  
  8. my $result = GetOptions("provides" => \$show_provides,
  9.             "requires" => \$show_requires,
  10.             "verbose"  => \$verbose,
  11.             "ignore=s" => \@ignores);
  12. my %ignores = map { $_ => 1 } @ignores;
  13.  
  14. exit(1) if (not $result);
  15.  
  16. my $deps = new DependencyParser;
  17. for my $file (grep /^[^-]/, @ARGV) {
  18.   $deps->process_file($file);
  19. }
  20.  
  21. if ($show_requires) {
  22.   for my $req ($deps->requires) {
  23.     my $verbage = "";
  24.     next if (exists $ignores{$req->to_string});
  25.     printf "%s%s\n", $req->to_string, $verbage;
  26.   }
  27. }
  28.  
  29. if ($show_provides) {
  30.   for my $prov ($deps->provides) {
  31.     my $verbage = "";
  32.     next if (exists $ignores{$prov->to_string});
  33.     printf "%s%s\n", $prov->to_string, $verbage;
  34.   }
  35. }
  36.  
  37. exit(0);
  38.  
  39. ####################
  40. # Dependency Class #
  41. ####################
  42. package Dependency;
  43. sub new {
  44.   my $class = shift;
  45.   my $type  = shift;
  46.   my $value = shift;
  47.  
  48.   return bless { type => $type, value => $value }, $class;
  49. }
  50.  
  51. sub value {
  52.   my $self = shift;
  53.  
  54.   if (@_) {
  55.     $self->{value} = shift;
  56.   }
  57.  
  58.   return $self->{value};
  59. }
  60.  
  61. sub filename {
  62.   my $self = shift;
  63.  
  64.   if (@_) {
  65.     $self->{filename} = shift;
  66.   }
  67.  
  68.   return $self->{filename};
  69. }
  70.  
  71. sub type {
  72.   my $self = shift;
  73.  
  74.   if (@_) {
  75.     $self->{type} = shift;
  76.   }
  77.  
  78.   return $self->{type};
  79. }
  80.  
  81. sub line_number {
  82.   my $self = shift;
  83.  
  84.   if (@_) {
  85.     $self->{line_number} = shift;
  86.   }
  87.  
  88.   return $self->{line_number};
  89. }
  90.  
  91. sub to_string {
  92.   my $self = shift;
  93.   my $type = $self->type;
  94.  
  95.   if ($type eq 'perl version') {
  96.     # we need to convert a perl release version to an rpm package
  97.     # version
  98.  
  99.     my $epoch = 0;
  100.     my $version = $self->value;
  101.     $version =~ s/_/./g;
  102.     $version =~ s/0+$//;
  103.  
  104.     if ($version =~ /^5.00[1-5]/) {
  105.       $epoch = 0;
  106.     }
  107.     elsif ($version =~ /^5.006/ or $version =~ /^5.6/) {
  108.       $version =~ s/00//g;
  109.       $epoch = 1;
  110.     }
  111.     elsif ($version =~ /^5.00[7-9]/ or $version =~ /^5.[7-9]/) {
  112.       $version =~ s/00//g;
  113.       $epoch = 2;
  114.     }
  115.     $version =~ s/\.$//;
  116.  
  117.     return sprintf "perl >= %d:%s", $epoch, $version;
  118.   }
  119.   elsif ($type eq 'virtual') { 
  120.        return $self->value; 
  121.   }
  122.   else {
  123.     return sprintf "perl(%s)", $self->value;
  124.   }
  125. }
  126.  
  127. package DependencyParser;
  128. sub new {
  129.   my $class = shift;
  130.   return bless {}, $class;
  131. }
  132.  
  133. sub requires {
  134.   return @{shift->{requires} || []};
  135. }
  136.  
  137. sub provides {
  138.   return @{shift->{provides} || []};
  139. }
  140.  
  141. sub add_provide {
  142.   my $self = shift;
  143.   my %params = @_;
  144.   die "DependencyParser->add_provide requires -filename, -provide, and -type"
  145.     if not exists $params{-filename} or not exists $params{-provide} or not exists $params{-type};
  146.  
  147.   #
  148.   # Make sure this one has not been added already
  149.   $self->{'provides_check'} ||= { };
  150.   return if(exists($self->{'provides_check'}->{$params{'-provide'}}));
  151.  
  152.   #
  153.   # Created dependency object
  154.   my $dep = new Dependency "provide", $params{-provide};
  155.   $dep->filename($params{-filename});
  156.   $dep->type($params{-type});
  157.   $dep->line_number($params{-line}) if $params{-line};
  158.  
  159.   #
  160.   # Add to requires check list
  161.   $self->{'provides_check'}->{$params{'-provide'}} = 1; 
  162.  
  163.   #
  164.   # Add to list
  165.   push @{$self->{provides}}, $dep;
  166. }
  167.  
  168. sub add_require {
  169.   my $self = shift;
  170.   my %params = @_;
  171.   die "DependencyParser->add_require requires -filename, -require, and -type"
  172.     if not exists $params{-filename} or not exists $params{-require} or not exists $params{-type};
  173.  
  174.   #
  175.   # Make sure this one has not been added already
  176.   $self->{'requires_check'} ||= { };
  177.   return if(exists($self->{'requires_check'}->{$params{'-require'}}));
  178.  
  179.   #
  180.   # Create dependency object.
  181.   my $dep = new Dependency "require", $params{-require};
  182.   $dep->filename($params{-filename});
  183.   $dep->type($params{-type});
  184.   $dep->line_number($params{-line}) if $params{-line};
  185.  
  186.   #
  187.   # Add to requires check list
  188.   $self->{'requires_check'}->{$params{'-require'}} = 1; 
  189.  
  190.   #
  191.   # Add to list
  192.   push @{$self->{requires}}, $dep;
  193. }
  194.  
  195. sub process_file {
  196.   my $self     = shift;
  197.   my $filename = shift;
  198.  
  199.   if (not open FH, "<$filename") {
  200.     # XXX: Should be die IMHO...JOO
  201.     warn "Can't open $filename: $!";
  202.     return;
  203.   }
  204.  
  205.   while (<FH>) {
  206.     next if m(^=(head[1-4]|pod|item)) .. m(^=cut);
  207.     next if m(^=over) .. m(^=back);
  208.     last if m/^__(DATA|END)__$/;
  209.  
  210.     if (m/^\s*package\s+([\w\:]+)\s*;/) {
  211.       $self->add_provide(-filename => $filename, -provide => $1, -type => "package", -line => $.);
  212.     }
  213.     if (m/^\s*use\s+base\s+(.*)/) {
  214.       # recognize the three main forms: literal string, qw//, and
  215.       # qw().  this is incomplete but largely sufficient.
  216.  
  217.       my @module_list;
  218.       my $base_params = $1;
  219.  
  220.       if ($base_params =~ m[qw\((.*)\)]) {
  221.     @module_list = split /\s+/, $1;
  222.       }
  223.       elsif ($base_params =~ m[qw/(.*)/]) {
  224.     @module_list = split /\s+/, $1;
  225.       }
  226.       elsif ($base_params =~ m/(['"])(.*)\1/) { # close '] to unconfuse emacs cperl-mode
  227.     @module_list = ($2);
  228.       }
  229.  
  230.       $self->add_require(-filename => $filename, -require => $_, -type => "base", -line => $.)
  231.          for @module_list;
  232.     }
  233.     elsif (m/^\s*(use|require)\s+(v?[0-9\._]+)/) {
  234.       $self->add_require(-filename => $filename, -require => $2, -type => "perl version", -line => $.);
  235.     }
  236.     elsif (m/^\s*use\s+([\w\:]+)/) {
  237.       $self->add_require(-filename => $filename, -require => $1, -type => "use", -line => $.);
  238.     }
  239.     elsif (m/^require\s+([\w\:]+).*;/) {
  240.       $self->add_require(-filename => $filename, -require => $1, -type => "require", -line => $.);
  241.     } 
  242.     #
  243.     # Allow for old perl.req Requires.  Support:
  244.     #
  245.     #    $RPM_Requires = "x y z";
  246.     #    our $RPM_Requires = "x y z";
  247.     # 
  248.     # where the rvalue is a space delimited list of provides.
  249.     elsif (m/^\s*(our\s+)?\$RPM_Requires\s*=\s*["'](.*)['"]/) {
  250.       foreach my $require (split(/\s+/, $2)) {
  251.           $self->add_require(
  252.            -filename => $filename, 
  253.            -require  => $require, 
  254.            -type     => "virtual", 
  255.            -line     => $.
  256.         );
  257.       }
  258.     }
  259.     #
  260.     # Allow for old perl.req Provides.  Support:
  261.     #
  262.     #    $RPM_Provides = "x y z";
  263.     #    our $RPM_Provides = "x y z";
  264.     # 
  265.     # where the rvalue is a space delimited list of provides.
  266.     elsif ( m/^\s*(our\s+)?\$RPM_Provides\s*=\s*["'](.*)['"]/) {
  267.       foreach my $provide (split(/\s+/, $2)) {
  268.         $self->add_provide(
  269.            -filename => $filename, 
  270.            -provide  => $provide, 
  271.            -type     => "virtual", 
  272.            -line     => $.
  273.         );
  274.       }
  275.     }
  276.   }
  277.  
  278.   close(FH);
  279. }
  280.  
  281. #######
  282. # POD #
  283. #######
  284. __END__
  285.  
  286. =head1 NAME
  287.  
  288. perldeps.pl - Generate Dependency Sets For a Perl Script
  289.  
  290. =head1 SYNOPSIS
  291.  
  292.     perldeps.pl --provides [--verbose] 
  293.         [--ignore=(dep) ... --ignore=(depN)]
  294.     perldeps.pl --requires [--verbose] 
  295.         [--ignore=(dep) ... --ignore=(depN)]
  296.  
  297. =head1 DESCRIPTION
  298.  
  299. This script examines a perl script or library and determines what the
  300. set of provides and requires for that file.  Depending on whether you
  301. use the C<--provides> or C<--requires> switch it will print either
  302. the provides or requires it finds.  It will print each dependency 
  303. on a seperate line simular to:
  304.  
  305.     perl(strict)
  306.     perl(warnings)
  307.     perl(Cmd)
  308.     perl(Dbug)
  309.     perl(Fdisk::Cmd)
  310.  
  311. This is the standard output that rpm expects from all of its autodependency
  312. scripts.
  313.  
  314. Provides are determined by C<package> lines such as:
  315.  
  316.     package Great::Perl::Lib;
  317.  
  318. Additionally, a script can infrom C<perldeps.pl> that it has additional
  319. provides by creating the variable C<$RPM_Provides>, and setting it to 
  320. a space delimited list of provides.  For instance:
  321.  
  322.     $RPM_Provides = "great stuff";
  323.  
  324. Would tell C<perldeps.pl> that this script provides C<great> and C<stuff>.
  325.  
  326. Requires are picked up from several sources:
  327.  
  328. =over 4
  329.  
  330. =item *
  331.  
  332. C<use> lines.   These can define either libraries to use or the version
  333. of perl required (see C<use> under C<perlfunc(1)).
  334.  
  335. =item *
  336.  
  337. C<require> lines.  Defines libraries to be sourced and evaled.
  338.  
  339. =item *
  340.  
  341. C<use base> lines.   These define base classes of the libraries and are 
  342. thus dependencies.  It can parse the following forms:
  343.  
  344.     use base "somelib";
  345.     use base qw(somelib otherlib);
  346.     use base qw/somelib otherlib);
  347.  
  348. =back
  349.  
  350. Aditionally, you can define the variable C<$RPM_Requires> to define
  351. additonal non-perl requirments.  For instance your script may require
  352. sendmail, in which case might do:
  353.  
  354.     $RPM_Requires = "sendmail";
  355.  
  356. =head1 OPTIONS
  357.  
  358. =over 4
  359.  
  360. =item B<--provides>
  361.  
  362. Print all provides.
  363.  
  364. =item B<--requires>
  365.  
  366. Print all requires.
  367.  
  368. =item B<--ignore=(dep)>
  369.  
  370. Ignore this dependency if found.
  371.  
  372. =back
  373.  
  374. =head1 EXIT STATUS
  375.  
  376. 0 success, 1 failure
  377.  
  378. =head1 SEE ALSO
  379.  
  380. /usr/lib/rpm/macros
  381.  
  382. =head1 BUGS
  383.  
  384. Does not generate version information on dependencies.  
  385.  
  386. =head1 AUTHOR
  387.  
  388. Chip Turner <cturner@redhat.com>
  389.