You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
640 lines
18 KiB
640 lines
18 KiB
## |
|
## rpmx -- RPM eXtension (Perl program) |
|
## Copyright (c) 2001-2002 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; |
|
my $specdir = `$CFG->{PRG}->{"rpm"} --define 'name $name' --eval '%_specdir'`; |
|
$specdir =~ s|\n+$||s; |
|
|
|
# make sure source and spec directory actually exists |
|
if (not -d $srcdir) { |
|
print(STDERR "rpm: Creating directory $srcdir\n"); |
|
system("mkdir $srcdir"); |
|
} |
|
if (not -d $specdir) { |
|
print(STDERR "rpm: Creating directory $specdir\n"); |
|
system("mkdir $specdir"); |
|
} |
|
|
|
# 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" or -f "$specdir/$srcfile") { |
|
my $size; |
|
if (-f "$srcdir/$srcfile") { |
|
$size = (stat("$srcdir/$srcfile"))[7]; |
|
} |
|
else { |
|
$size = (stat("$specdir/$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" . |
|
" --progress-bar" . |
|
" --output $srcdir/$srcfile" . |
|
" $srcurl"; |
|
my $rc = system($cmd); |
|
print STDOUT "\n"; |
|
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"; |
|
} |
|
} |
|
|
|
|