spectool

#!/usr/bin/perl -w

################################################################
#
# Copyright (c) 1995-2014 SUSE Linux Products GmbH
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 or 3 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################

=head1 spectool

spectool - tool to work with rpm spec files

=head1 SYNOPSIS

spectool [options] specfiles...

=head1 OPTIONS

=over 4

=item B<--help>

display help as manpage

=item B<--dist>=I<STRING>

set distribution, e.g. "11.1-i586" or path to config

=item B<--archpath>=I<STRING>

compatible architecture separated by colon, e.g. C<i586:i486:i386>.
Autotected if missing.

=item B<--configdir>=I<STRING>

path to config files if B<--dist> didn't specify a full path

=item B<--define>=I<STRING>

=item B<--with>=I<STRING>

=item B<--without>=I<STRING>

same meaning as in rpmbuild

=item B<--tag>=I<STRING>

print tag from spec file, e.g. C<version>. Regexp is also possible,
e.g. C</source[01]/>

=item B<--sources>

print package source files. If a file C<sources> or
C<I<packagename>.sources> is present verify the checksums against
that.

=over 4

=item B<--update>

update the checksums

=item B<--download>

download missing sources

=back

=back

=head1 DESCRIPTION

The B<--sources> option allows to manage a sources file in a way
similar to Fedora. The sources file lists the check sums and file
names of the binary files specified in the spec file.

B<--sources> without further options compares the check sums of all
files and prints a report consisting of a character that describes
the status of the file and the file name. Meaning of the characters
is as follows:

=over 4

=item B<.> check sum matches

=item B<!> check sum broken

=item B<d> file is missing, checksum known. Can be verified after download

=item B<-> file is missing and checksum unknown

=item B<_> file is present but checksum unknown

=item B<t> text file, will be skipped for check sums

=item B<?> check sum known but not referenced from spec file

=back

Additionally specifying B<--update> recomputes all check sums and
updates the sources file.

With B<--download> all missing files are downloaded if the spec file
has an http or ftp url.

=head2 FORMAT OF THE SOURCES FILE

Lines of the form
<checksum> <whitespace> <filename>

=head2 NAME OF THE SOURCES FILE

A file named C<sources> is preferred if present for compatibility
with Fedora. It only contains md5 sums. If that file is not present
the C<.spec> suffix of the spec file is replaced with C<.sources>
and the this name used as sources file (e.g. C<foo.spec> ->
C<foo.sources>). In this file sha1 is preferred. Also, the name of
the algorithm is prepended with colon to the check sum.

=cut

my $builddir;

BEGIN {
  $builddir = ($::ENV{'BUILD_DIR'} || '/usr/lib/build');
  unshift @INC, $builddir;
}

use strict;

use Build;
use Pod::Usage;
use Getopt::Long;
Getopt::Long::Configure("no_ignore_case");

my (@opt_showtag, $opt_sources, $opt_update, $opt_download);

sub parse_depfile;

my ($dist, $rpmdeps, $archs, $configdir, $useusedforbuild);
my %options;

GetOptions (
  \%options,
  "help" => sub { pod2usage(-exitstatus => 0, -verbose => 2) },

  "dist=s" => \$dist,
  "archpath=s" => \$archs,
  "configdir=s" => \$configdir,
  "define=s" => sub { Build::define($_[1]) },
  "with=s" => sub { Build::define("_with_".$_[1]." --with-".$_[1]) },
  "without=s" => sub { Build::define("_without_".$_[1]." --without-".$_[1]) },

  "tag=s" => \@opt_showtag,
  "sources" => \$opt_sources,
  "update" => \$opt_update,
  "download" => \$opt_download,
  "download-force",
  "download-recompress=s",
  "download-outdir=s",
  "download-compare=s",
  "download-delete-identical",
) or pod2usage(1);

pod2usage(1) unless @ARGV;

my $ua;

my @specs = @ARGV;

die "--download must be used together with --sources\n" if ($opt_download && !$opt_sources);
die "--update must be used together with --sources\n" if ($opt_update && !$opt_sources);

$options{'download-recompress'} ||= 'auto';
$options{'download-outdir'}.='/' if ($options{'download-outdir'} && $options{'download-outdir'} !~ /\/$/);
$options{'download-outdir'} ||= '';
$options{'download-compare'}.='/' if ($options{'download-compare'} && $options{'download-compare'} !~ /\/$/);
$options{'download-compare'} ||= '';

my @archs;
if (!defined $archs) {
  use POSIX qw/uname/;
  my %archmap = qw/x86_64 i686 i686 i586 i586 i486 i486 i386/;
  my @a = uname();
  push @archs, $a[4];
  while(exists $archmap{$archs[-1]}) {
    push @archs, $archmap{$archs[-1]};
  }
} else {
  @archs = split(':', $archs);
}
push @archs, 'noarch' unless grep {$_ eq 'noarch'} @archs;

unless ($dist) {
    $dist = 'spectool';
#    $dist = `rpm -q --qf '%{DISTRIBUTION}' rpm 2>/dev/null`;
#    $dist = Build::dist_canon($dist||'', $archs[0]);
}

if($dist !~ /\// && !defined $configdir) {
  if($0 =~ /^\//) {
    use File::Basename qw/dirname/;
    $configdir = dirname($0).'/configs';
    undef $configdir unless -e $configdir.'/sl11.3.conf';
  } else {
    $configdir = $builddir.'/configs';
    undef $configdir unless -e $configdir.'/sl11.3.conf';
  }
  if(!defined $configdir) {
    print STDERR "please specify config dir\n";
  }
}

#######################################################################

# param: array to fill, spec file
# return: file name
sub read_sources_digests($$)
{
  my $files = shift;
  my $spec = shift;
  my $srcfile = 'sources';
  if (! -r $srcfile) {
    $srcfile = $spec;
    $srcfile =~ s/spec$/sources/;
  }
  if (open (F, '<', $srcfile)) {
    while(<F>) {
      chomp;
      my ($sum, $file) = split(/ +/, $_, 2);
      $files->{$file} = $sum;
    }
    close F;
  }
  return $srcfile;
}

# param: file, oldsum
# return: newsum or undef if match
sub check_sum($$)
{
  my $file = shift;
  my $oldsum = shift || 'sha1:';
  my $sum;
  my $type = 'md5:';
  if($oldsum =~ /^(\S+:)/) {
    $type = $1;
  } else {
    $oldsum = $type.$oldsum;
  }
  if ($type eq 'md5:') {
    $sum = $type.`md5sum $file` || die "md5sum failed\n";
  } elsif ($type eq 'sha1:') {
    $sum = $type.`sha1sum $file` || die "sha1sum failed\n";
  } else {
    die "unsupported digest type '$type'\n";
  }
  $sum =~ s/ .*//s;
  if($sum ne $oldsum) {
    return $sum;
  }
  return undef;
}

sub download($$)
{
  my ($url, $dest) = @_;
  my $retry = 3;
  while ($retry--) {
    my $res = $ua->mirror($url, $dest);
    last if $res->is_success;
    # if it's a redirect we probably got a bad mirror and should just retry
    return 0 unless $retry && $res->previous;
    warn "retrying $url\n";
  }
  return 1;
}

#######################################################################

my $ret = 0;
for my $spec (@specs) {
  my $cf = Build::read_config_dist($dist, $archs[0], $configdir);
  my $parsed = Build::parse($cf, $spec);

  if (!defined $parsed) {
    die "can't parse $spec\n";
  }

  for my $tag (@opt_showtag) {
    if($tag =~ /^\/(.+)\/$/) {
      my $expr = $1;
      for my $t (keys %$parsed) {
        if ($t =~ $expr) {
          push @opt_showtag, $t;
        }
      }
    } else {
      if(exists $parsed->{lc $tag}) {
        print $tag, ": ";
        my $v = $parsed->{lc $tag};
        $v = join(' ', @$v) if (ref $v eq 'ARRAY');
        print $v, "\n";
      } else {
        print STDERR "$tag does not exist\n";
      }
    }
  }

  if ($opt_sources) {
    my $files = {};
    my $srcfile = read_sources_digests($files, $spec);
    if ($opt_download) {
      unless ($ua) {
	use LWP::UserAgent;
	$ua = LWP::UserAgent->new(
	  agent => "openSUSE build service",
	  env_proxy => 1,
	  timeout => 42);
      }

      for my $t (keys %$parsed) {
        next unless ($t =~ /^(?:source|patch)\d*/);
        my $url = $parsed->{$t};
        next unless $url =~ /^(?:https?|ftp):\/\//;
        my $file = $url;
        $file =~ s/.*\///;
	my $src = $options{'download-compare'}.$file;
        next if -e $src && !($options{'download-force'} || $options{'download-delete-identical'});
        print "Downloading $file...\n";
	my $dest = $options{'download-outdir'}.$file;
	print "$url -> $dest\n";

        if(!download($url, $dest) && $options{'download-recompress'} ne 'no') {
	  # TODO
          # let's see if the file was recompressed
          if($url =~ s/\.bz2$/.gz/ && $file =~ s/\.bz2$/.gz/
            && !download($url, $dest)) {
            if(system('bznew', $dest) == 0) {
              print STDERR "Used $file and recompressed to bz2 instead\n";
            } else {
              unlink $dest;
            }
          } else {
            print STDERR "Downloading $file failed\n";
          }
        }
	if ($options{'download-delete-identical'} && $options{'download-outdir'}
	&& system('cmp', '-s', $dest, $src) == 0) {
	  unlink($dest);
	}
      }
    }
    if ($opt_update) {
      my $changed;
      for my $t (keys %$parsed) {
        next unless ($t =~ /^(?:source|patch)\d*/);
        my $file = $parsed->{$t};
        $file =~ s/.*\///;
        next unless -B $file;
        my $sum = check_sum($file, ($files->{$file} || ($srcfile eq 'sources'?'md5:':'sha1:')));
        if($sum) {
          print STDERR "update $file\n";
          $files->{$file} = $sum;
          $changed = 1;
        }
      }
      if($changed) {
        if(open(F, '>', $srcfile)) {
          for my $file (keys %$files) {
            $files->{$file} =~ s/^md5:// if $srcfile eq 'sources';
            print F $files->{$file}, ' ', $file, "\n";
          }
          close F;
        }
      }
    } else {
      for my $t (keys %$parsed) {
        next unless ($t =~ /^(?:source|patch)\d*/);
        my $file = $parsed->{$t};
        $file =~ s/.*\///;
        if (!exists $files->{$file}) {
          if (! -e $file) {
            print '- ';
          } elsif (-B $file) {
            print '_ ';
          } else {
            print 't ';
          }
        } elsif (! -e $file) {
            print 'd ';
            delete $files->{$file};
        } else {
          my $sum = check_sum($file, $files->{$file});
          if($sum) {
            print '! ';
	    $ret = 1;
          } else {
            print '. ';
          }
          delete $files->{$file};
        }
        print $parsed->{$t}, "\n";
      }
      for my $file (keys %$files) {
        print "? $file\n";
      }
    }
  }
}

exit $ret;