openpkg-packages/openpkg/rpmx.pl

##
##  rpmx -- RPM eXtension (Perl program)
##  Copyright (c) 2001 Ralf S. Engelschall <rse@engelschall.com>
##
##  list all files in the hierarchy which are not listed in RPM database
##  $ rpm --stowaway
##
##  generate repository information (on server only)
##  $ rpm --makeindex <pkgdir>
##
##  update local database with latest repository information
##  $ rpm --update
##
##  update the package sources by downloading missing files
##  $ rpm --fetch <spec-file>
##
##  query repository information
##  $ rpm -rqa
##  $ rpm -rqai
##  $ rpm -rqal
##  $ rpm -rqalv
##  $ rpm -rqi package
##  $ rpm -rql package
##  $ rpm -rqlv package
##
##  update already installed packages
##  $ rpm -Uvhs '*'
##
##  install/update a particular package and its dependencies
##  $ rpm -Uvhs file-pattern
##
##  erase a particular package and its dependencies
##  $ rpm -es file-pattern
##

require 5.000;

use IO::File;
use IO::Handle;
use Data::Dumper;

$|++;

##  ______________________________________________________________________
##
##  Determine Configuration and Run-Time Information
##  ______________________________________________________________________
##

my $CFG = {
    'PRG' => {},
    'RC' => {},
    'OPT' => [],
    'OPT_OPT' => {},
    'OPT_ARG' => {},
    'ARG' => [],
};

#   determine path to executables
my $prefix = shift(@ARGV);
$CFG->{PRG}->{"rpm"}   = $prefix."/bin/rpm";
$CFG->{PRG}->{"curl"}  = $prefix."/lib/openpkg/curl";
$CFG->{PRG}->{"bzip2"} = $prefix."/lib/openpkg/bzip2";
$CFG->{PRG}->{"gzip"}  = $prefix."/lib/openpkg/gzip";

#   determine a few RPM rc-file configuration variables
my $var;
my $vars = '';
foreach $var (qw(
    _dbpath _rpmdir _srcrpmdir _tmppath
    _target
    l_prefix
    l_repo_cache
    l_repo_0 l_repo_1 l_repo_2 l_repo_3 l_repo_4
    l_repo_5 l_repo_6 l_repo_7 l_repo_8 l_repo_9
)) {
    $vars .= "${var}=\%{${var}};";
}
my @assign = split(/;/, `$CFG->{PRG}->{"rpm"} --eval '$vars'`);
foreach $assign (@assign) {
    if ($assign =~ m|^(\S+)=(.*)$|s) {
        $CFG->{RC}->{$1} = $2;
    }
}

#   parse argument line
#foreach my $arg (@ARGV) {
#    print "<$arg>";
#}
#print "\n";
my $op = 'pass';
my $isopt = 1;
my $optname = '';
my $arg;
foreach $arg (@ARGV) {
    if ($arg =~ m/^--(stowaway|makeindex|update|fetch|repo|smart)$/) {
        $op = $1;
        next;
    }
    if ($arg eq '--') {
        $isopt = 0;
        next;
    }
    if ($isopt) {
        push(@{$CFG->{OPT}}, $arg);
        if ($arg =~ m|^-.|) {
            $optname = $arg;
            $CFG->{OPT_OPT}->{$optname} = 1;
            $CFG->{OPT_ARG}->{$optname} = '--';
        }
        else {
            $CFG->{OPT_ARG}->{$optname} = $arg;
        } 
    }
    else {
        push(@{$CFG->{ARG}}, $arg);
    }
}
#print Data::Dumper->Dump([$CFG]);
if ($op eq 'pass') {
    # exec $CFG->{PRG}->{"rpm"} (@{$CFG->{OPT}}, @{$CFG->{ARG}});
}
else {
    my $rc;
    #eval "\$rc = \&op_${op}(\$CFG);";
    if ($op eq 'stowaway') {
        $rc = &op_stowaway($CFG);
    }
    elsif ($op eq 'makeindex') {
        $rc = &op_makeindex($CFG);
    }
    elsif ($op eq 'update') {
        $rc = &op_update($CFG);
    }
    elsif ($op eq 'fetch') {
        $rc = &op_fetch($CFG);
    }
    elsif ($op eq 'repo') {
        $rc = &op_repo($CFG);
    }
    elsif ($op eq 'smart') {
        $rc = &op_smart($CFG);
    }
    exit($rc);
}

##  ______________________________________________________________________
##
##  Database Handling
##  ______________________________________________________________________
##

#   read database file from disk
sub db_load {
    my ($dbfile) = @_;

    if (not -f $dbfile) {
        my $DB = {};
        return $DB;
    }
    my $fp = new IO::File ("<$dbfile") || die "cannot read from Database file `$dbfile'";
    my $db = '';
    my $buf; 
    $db .= $buf while ($fp->read($buf, 128*1024));
    $fp->close;

    my $DB = {};
    $db =~ s|<rpm\s+(\S+)>\n(.+?)</rpm>|&load_rpm($DB, $2, $1), ''|isge;
    sub load_rpm {
        my ($DB, $db, $rpm) = @_;
        $DB->{$rpm} = {};
        $db =~ s/<(repos|info|files|requires)>\n(.+?)<\/\1>/$DB->{$rpm}->{uc($1)} = $2, ''/isge;
    }
    return $DB;
}

#   write database file to disk
sub db_store {
    my ($dbfile, $DB) = @_;

    my $fp = new IO::File (">$dbfile") || die "cannot store to Database file `$dbfile'";
    my $rpm;
    foreach $rpm (sort(keys(%{$DB}))) {
        print $fp "<rpm $rpm>\n" .
                  "<repos>\n" .
                  $DB->{$rpm}->{REPOS} .
                  "</repos>\n" .
                  "<requires>\n" .
                  $DB->{$rpm}->{REQUIRES} .
                  "</requires>\n" .
                  "<info>\n" .
                  $DB->{$rpm}->{INFO} .
                  "</info>\n" .
                  "<files>\n" .
                  $DB->{$rpm}->{FILES} .
                  "</files>\n" .
                  "</rpm>\n";
    }
    $fp->close;
    return;
}

##  ______________________________________________________________________
##
##  Fetch an URL
##  ______________________________________________________________________
##

sub fetch_url {
    my ($CFG, $src, $dst) = @_;

    #   make sure file URLs have a fully-qualified scheme.
    if ($src =~ m|^/.+|) {
        $src = "file://$src" 
    }

    #   make sure only schemes curl(1) supports are used.
    if ($src !~ m;^(file|http|ftp)://.+;) {
        return "invalid URL - only file, http and ftp schemes supported";
    }

    #   try to fetch the URL
    unlink("$dst.err");
    unlink("$dst.hdr");
    $rc = system($CFG->{PRG}->{"curl"}.
                 " --location" .
                 " --max-time 120" . 
                 " --stderr $dst.err" .
                 " --dump-header $dst.hdr" .
                 " --output $dst '$src'");

    #   check whether command failed
    if ($rc != 0) {
        open(FP, "<$dst.err");
        my $err = <FP>;
        close(FP);
        $err =~ s|\n$||;
        return $err;
    }

    #   check whether remote sites failed
    if (-s "$dst.hdr") {
        open(FP, "<$dst.hdr");
        my $response = <FP>;
        close(FP);
        if ($response =~ m|^HTTP/[\d.]+\s+(\d+)|) {
            if ($1 ne 200) {
                $response =~ s|\n$||;
                return $response;
            }
        }
    }
     
    #   cleanup
    unlink("$dst.err");
    unlink("$dst.hdr");

    return '';
}

##  ______________________________________________________________________
##
##  List all files which are not known to RPM
##  ______________________________________________________________________
##

sub op_stowaway {
    my ($CFG) = @_;
    my $file;

    my $prefix = $CFG->{RC}->{"l_prefix"};
    my $rpm = $CFG->{PRG}->{"rpm"};
    print "OpenPKG Hierarchy $prefix\n";
    my @known = `$rpm -qla`;
    my %known = ();
    foreach $file (@known) {
        $file =~ s|\n$||s;
        $known{$file} = 1;
    }
    my @exist = `cd $prefix && find . -print 2>/dev/null`;
    foreach $file (sort(@exist)) {
        $file =~ s|^\./|$prefix/|s;
        $file =~ s|\n$||s;
        next if ($file eq '.');
        if (not $known{$file}) {
            next if ($file =~ m|^$prefix/RPM/?|);
            print "$file\n";
        }
    }
    return 0; 
}

##  ______________________________________________________________________
##
##  Generate Repository Index
##  ______________________________________________________________________
##

sub op_makeindex {
    my ($CFG) = @_;

    if ($#{$CFG->{ARG}} ne 0) {
        print STDERR "rpm: option --makeindex requires an argument\n";
        return 1;
    }
    my $dir = $CFG->{ARG}->[0];
    if (not -d $dir) {
        print STDERR "rpm: --makeindex argument `$dir' is not a directory\n";
        return 1;
    }
    my $index = '';
    my $file;
    my $rpm = $CFG->{PRG}->{"rpm"};
    foreach $file (sort(glob("$dir/*.rpm"))) {
        $file =~ s|^$dir/*||;
        $index .= "<rpm $file>\n";
        $index .= "<requires>\n";
        $index .= `$rpm -qp --qf '[%{REQUIRENAME} %{REQUIREFLAGS:depflags} %{REQUIREVERSION}\n]' $dir/$file`;
        $index .= "</requires>\n";
        $index .= "<info>\n";
        $index .= `$rpm -qpi $dir/$file`;
        $index .= "</info>\n";
        $index .= "<files>\n";
        $index .= `$rpm -qplv $dir/$file`;
        $index .= "</files>\n";
        $index .= "</rpm>\n";
    }
    open(FP, "|".$CFG->{PRG}->{"bzip2"}.">$dir/INDEX.bz2");
    print FP $index;
    close(FP);
    return 0;
}

##  ______________________________________________________________________
##
##  Fetch Repository Indices
##  ______________________________________________________________________
##

sub op_update {
    my ($CFG) = @_;

    my $DB = {};
    my $tmpfile = $CFG->{RC}->{_tmppath}."/rpm.update.tmp.".$$;

    for ($i = 9; $i >= 0; $i--) {
        my $repo = $CFG->{RC}->{"l_repo_$i"};
        next if (not defined($repo) or $repo eq '' or $repo eq '-');
        $repo =~ s|([^/])$|$1/|;

        my $src = $repo."INDEX.bz2";

        my $prefix = $src;
        $prefix = substr($prefix, 0, 37)."..." if (length($prefix) > 40);
        printf(STDOUT "%-40s ", $prefix);

        if (($err = &fetch_url($CFG, $src, $tmpfile))) {
            $err = substr($err, 0, 37)."..." if (length($err) > 40);
            print STDOUT "FAILED: $err\n";
            next;
        }

        my $size = (stat($tmpfile))[7];
        print STDOUT "OK: $size bytes\n";

        my $fh = new IO::Handle; 
        open($fh, $CFG->{PRG}->{"bzip2"}." -d -c $tmpfile|");
        my $db = '';
        my $buf; 
        $db .= $buf while ($fh->read($buf, 128*1024));
        $fh->close;

        unlink($tmpfile);

        $db =~ s|<rpm\s+(\S+)>\n(.+?)</rpm>|&load_rpm2($DB, $repo, $2, $1), ''|isge;
        sub load_rpm2 {
            my ($DB, $repo, $db, $rpm) = @_;
            my $target = $CFG->{RC}->{_target};
            return if ($rpm !~ m|\.src\.rpm$| and $rpm !~ m|\.$target\.rpm$|);
            my $repos = ''; 
            if (defined($DB->{$rpm})) {
                $repos = $DB->{$rpm}->{REPOS};
            }
            $repos = $repo."\n".$repos;
            $DB->{$rpm} = {};
            $DB->{$rpm}->{REPOS} = $repos;
            $db =~ s/<(info|files|requires)>\n(.+?)<\/\1>/$DB->{$rpm}->{uc($1)} = $2, ''/isge;
        }
    }

    my $dbfile = $CFG->{RC}->{_dbpath}."/Repository";
    &db_store($dbfile, $DB);

    return 0;
}

##  ______________________________________________________________________
##
##  Repository Queries
##  ______________________________________________________________________
##

sub op_repo {
    my ($CFG) = @_;

    #   argument line consistency check
    if (not defined($CFG->{OPT_OPT}->{"-q"})) {
        print STDERR "rpm: option --repo always requires option -q\n";
        return 1;
    }
    my @optok = (qw(--rcfile -q --all -i --list --verbose));
    my $opt;
    my $check;
    foreach $opt (keys(%{$CFG->{OPT_OPT}})) {
        my $ok = 0;
        foreach $check (@optok) {
            if ($check eq $opt) {
                $ok = 1;
                last;
            }
        }
        if (not $ok) {
            print STDERR "rpm: option $opt not supported in conjunction with option --repo\n";
            return 1;
        }
    }

    #   load database
    my $dbfile = $CFG->{RC}->{_dbpath}."/Repository";
    if (not -f $dbfile) {
        print STDERR "rpm: option --repo requires local repository index.\n";
        print STDERR "rpm: run \"rpm --update\", first.\n";
        return 1;
    }
    my $DB = &db_load($dbfile);

    #   perform query operation
    my $target = $CFG->{RC}->{_target};
    my $rpm;
    my $rpms = {};
    foreach $rpm (sort(keys(%{$DB}))) {
        my $name = $rpm;
        $name =~ s|\.src\.rpm$||;
        $name =~ s|\.${target}\.rpm$||;
        next if (defined($rpms->{$name}));
        $rpms->{$name} = 1;
        if ((defined($CFG->{ARG}->[0]) and $rpm =~ m|^$CFG->{ARG}->[0]|)
            or defined($CFG->{OPT_OPT}->{"--all"})) {
            if (not defined($CFG->{OPT_OPT}->{"--list"}) and not defined($CFG->{OPT_OPT}->{"-i"})) {
                print "$name\n";
            }
            if (defined($CFG->{OPT_OPT}->{"-i"})) {
                print $DB->{$rpm}->{INFO};
            }
            if (defined($CFG->{OPT_OPT}->{"--list"})) {
                my $files = $DB->{$rpm}->{FILES};
                if (not defined($CFG->{OPT_OPT}->{"--verbose"})) {
                    if (not ($files =~ s|^.*\s+(\S+\s+->\s+\S+)\s*$|$1|mg)) {
                        $files =~ s|^.*\s+(\S+)\s*$|$1|mg;
                    }
                }
                print "$files";
            }
        }
    }
}

##  ______________________________________________________________________
##
##  Fetch Operation
##  ______________________________________________________________________
##

sub op_fetch {
    my ($CFG) = @_;
    
    if ($#{$CFG->{ARG}} ne 0) {
        print STDERR "rpm: option --fetch requires an argument\n";
        return 1;
    }
    my $spec = $CFG->{ARG}->[0];
    if (not -f $spec) {
        print STDERR "rpm: spec file `$spec' not found\n";
        return 1;
    }

    #   determine package name and source directory
    my $name = $spec;
    $name =~ s|\.[^.]+$||;
    $name =~ s|^.+/([^/]+)$|$1|;
    my $srcdir = `$CFG->{PRG}->{"rpm"} --define 'name $name' --eval '%_sourcedir'`;
    $srcdir =~ s|\n+$||s;

    #   parse spec file
    my $DEF = {};
    my $SRC = {};
    open(SPEC, "<$spec");
    while (<SPEC>) {
        s|\n+$||s;
        if (m/^([a-zA-Z_][a-zA-Z0-9_]*):\s*(.+?)\s*$/) {
            $DEF->{lc($1)} = $2;
        }
        if (m/^%define\s+([a-zA-Z_][a-zA-Z0-9_]*)\s+(.+?)\s*$/) {
            $DEF->{lc($1)} = $2;
        }
        if (m/^((Source|Patch)[0-9]+?):\s*(.+)\s*$/i) {
            my ($srcid, $srcurl) = ($1, $3);
            1 while ($srcurl =~ s|%{?([a-zA-Z_][a-zA-Z0-9_]*)}?|$DEF->{lc($1)}|sge);
            my $srcfile = $srcurl;
            $srcfile =~ s|^.*/([^/]+)$|$1|;
            my $file = $srcfile;
            $file = substr($file, 0, 40) if (length($file) > 40);
            printf(STDERR "%-9s %-40s ", "$srcid:", $file);
            if (-f "$srcdir/$srcfile") {
                my $size = (stat("$srcdir/$srcfile"))[7];
                if ($size > 1024*1024) {
                    $size = sprintf("%.1fMB", $size / (1024*1024));
                }
                elsif ($size > 1024) {
                    $size = sprintf("%.0fKB", $size / 1024);
                }
                else {
                    $size = sprintf("%d", $size);
                }
                print STDERR "...OK [$size]\n";
            }
            else {
                print STDERR "...MISSING\n";
                print STDERR "rpm: Fetching $srcurl\n";
                my $cmd = $CFG->{PRG}->{"curl"}.
                          " --location" .
                          " --output $srcdir/$srcfile" .
                          " $srcurl";
                my $rc = system($cmd);
                if ($rc != 0) {
                    print STDERR "rpm: Failed to fetch source file `$srcfile'\n";
                    return 1;
                }
            }
        }
    }
    close(SPEC);

    return 0;
}

##  ______________________________________________________________________
##
##  Smart Operations
##  ______________________________________________________________________
##

sub op_smart {
    my ($CFG) = @_;

    if ($#{$CFG->{ARG}} ne 0) {
        print STDERR "rpm: option --smart requires one argument\n";
        return 1;
    }
    my $package = $CFG->{ARG}->[0];

    #   load database
    my $dbfile = $CFG->{RC}->{_dbpath}."/Repository";
    if (not -f $dbfile) {
        print STDERR "rpm: option --smart requires local repository index.\n";
        print STDERR "rpm: run \"rpm --update\", first.\n";
        return 1;
    }
    my $DB = &db_load($dbfile);

    my $deps = [];
    &find_deps($CFG, $DB, $deps, $package, '=', 'ANY');
    sub find_deps {
        my ($CFG, $DB, $deps, $pkg, $op, $ver) = @_;
        push(@{$deps}, "$pkg $op $ver");
        my $rpm;
        foreach $rpm (keys(%{$DB})) {
            if (&match_rpm($CFG, $rpm, $pkg, $op, $ver)) {
                my $req;
                foreach $req (split(/\n/, $DB->{$rpm}->{REQUIRES})) {
                    $req =~ s|^\s+||sg;
                    $req =~ s|\s+$||sg;
                    if ($req =~ m|^OpenPKG$| or
                        $req =~ m|^rpmlib\(.+\)|) {
                        next;
                    }
                    if ($req =~ m|^(\S+)$|) {
                        $req .= " = ANY";
                    }
                    if ($req =~ m|^(\S+)\s+([=><]+)\s+(\S+)$|) {
                        &find_deps($CFG, $DB, $deps, $1, $2, $3);
                    }
                }
            }
        }
    }
    sub match_rpm {
        my ($CFG, $rpm, $name, $op, $ver) = @_;
        my $rc = 0;
        my $target = $CFG->{RC}->{_target};
        $rpm =~ s|\.src\.rpm$||;
        $rpm =~ s|\.${target}\.rpm$||;
        if ($rpm =~ m|^(\S+)-([^-]+-[^-]+)$|) {
            my ($tname, $tver) = ($1, $2);
            if ($name eq $tname and &match_version($ver, $op, $tver)) {
                $rc = 1;
            }
        }
        return $rc;
    }
    sub match_version {
        my ($ver, $op, $tver) = @_;
        return 1;
    }
    my $dep;
    foreach $dep (@{$deps}) {
        print "$dep\n";
    }
}