OpenPKG CVS Repository
http://cvs.openpkg.org/
____________________________________________________________________________
Server: cvs.openpkg.org Name: Ralf S. Engelschall
Root: /v/openpkg/cvs Email: [EMAIL PROTECTED]
Module: openpkg-tools Date: 24-Jul-2006 16:51:16
Branch: HEAD Handle: 2006072415511500
Modified files:
openpkg-tools/cmd index.pl
Log:
Complete refactoring of 'openpkg index' source code (without any
semantical changes).
Summary:
Revision Changes Path
1.8 +522 -496 openpkg-tools/cmd/index.pl
____________________________________________________________________________
patch -p0 <<'@@ .'
Index: openpkg-tools/cmd/index.pl
============================================================================
$ cvs diff -u -r1.7 -r1.8 index.pl
--- openpkg-tools/cmd/index.pl 4 Jul 2006 15:47:57 -0000 1.7
+++ openpkg-tools/cmd/index.pl 24 Jul 2006 14:51:15 -0000 1.8
@@ -22,47 +22,147 @@
## SUCH DAMAGE.
##
-require 5;
+#############################################################################
+##
+## MAIN PROCEDURE
+##
+#############################################################################
+require 5;
use strict;
-
use Getopt::Std;
-use OpenPKG::Ctx;
-getopts('r:p:C:o:ci');
-use vars qw/$opt_r $opt_p $opt_C $opt_o $opt_c $opt_i/;
-
use FileHandle;
use DirHandle;
-my $ctx = new OpenPKG::Ctx;
-my $l_prefix = $ctx->prefix();
+# determine OpenPKG instance prefix via
+# 1. the environment of the "openpkg build" framework
+# 2. the installation path of the script
+# 3. the installation path of the Perl interpreter
+# 4. the path of the "openpkg" command in $PATH
+my $l_prefix = $ENV{'OPENPKG_PREFIX'};
+if (not $l_prefix) {
+ ($l_prefix) = ($0 =~
m/^(.+)\/lib(exec)?\/openpkg(-tools)?\/build(\.pl)?$/);
+}
+if (not $l_prefix) {
+ ($l_prefix) = ($^X =~ m/^(.+)\/bin\/perl.*$/);
+}
+if (not $l_prefix) {
+ $l_prefix = (`(which openpkg) 2>/dev/null` =~ m/^(.+)\/bin\/openpkg$/);
+}
+if (not -x "$l_prefix/bin/openpkg") {
+ die "openpkg:build:FATAL: cannot determine OpenPKG instance prefix";
+}
+
+# determine tools
my $RPM = ((-f "$l_prefix/bin/openpkg" && -f
"$l_prefix/libexec/openpkg/rpm") ?
"$l_prefix/bin/openpkg rpm" : "$l_prefix/bin/rpm");
my $R2C = ((-f "$l_prefix/bin/openpkg" && -f
"$l_prefix/libexec/openpkg/rpm2cpio") ?
"$l_prefix/bin/openpkg rpm2cpio" : "$l_prefix/bin/rpm2cpio");
my $BZ = "$l_prefix/lib/openpkg/bzip2 -9";
-#########################################################################
+# parse command line
+use vars qw/$opt_r $opt_p $opt_C $opt_o $opt_c $opt_i/;
+getopts('r:p:C:o:ci');
+if ($#ARGV < 0) {
+ print "openpkg:index:USAGE: openpkg index [-r resource] [-p platform]
[-C cache.db] [-o index.rdf] [-c] [-i] dir ...\n";
+ exit(1);
+}
+
+# optionally open cache file
+my %cache;
+if ($opt_C) {
+ eval {
+ require DB_File;
+ };
+ if ($@) {
+ die "openpkg:index:FATAL: The -C option requires an installed
DB_File perl module.";
+ }
+ tie %cache, 'DB_File', $opt_C, O_CREAT|O_RDWR, 0666, $DB_File::DB_HASH
+ or die "openpkg:index:FATAL: cannot tie cache '$opt_C' ($!)";
+}
+
+# provide default for repository path
+$opt_r = 'OpenPKG-CURRENT/Source/' if (not defined($opt_r));
+
+# create make_resource function closure
+my $make_resource = gen_make_resource();
+
+# determine output channel
+my $fh;
+my $tmpo;
+if (defined($opt_o)) {
+ $tmpo = $opt_o . '.tmp';
+ if ($opt_c) {
+ $fh = new FileHandle "| $BZ -c > '$tmpo'"
+ or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
+ } else {
+ $fh = new FileHandle "> $tmpo"
+ or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
+ }
+} else {
+ if ($opt_c) {
+ $fh = new FileHandle "| $BZ -c"
+ or die "openpkg:index:FATAL: cannot write to stdout ($!)";
+ } else {
+ $fh = new FileHandle ">&=1"
+ or die "openpkg:index:FATAL: cannot write to stdout ($!)";
+ }
+}
+
+# generate XML/RDF output
+xml_head($fh, $opt_r);
+foreach my $prefix (@ARGV) {
+ my $list;
+ if (-d $prefix) {
+ if ($opt_i) {
+ $list = list_rpmdir($prefix);
+ } else {
+ $list = list_specdir($prefix);
+ }
+ } else {
+ $list = [ $prefix ];
+ $prefix = dirname($prefix);
+ }
+ write_index($fh, $prefix, $opt_r, $opt_p, $list, $opt_C ? \%cache :
undef);
+}
+xml_foot($fh);
-#
-# escape XML special characters for output in RDF file
-#
-# remove trailing whitespace
-# remove common leading whitespace
-#
+# close output channel
+$fh->close()
+ or die "openpkg:index:FATAL: write error on output ($!)";
+
+# post-process output
+if (defined($tmpo)) {
+ rename($tmpo, $opt_o)
+ or die "openpkg:index:FATAL: cannot rename $tmpo to $opt_o ($!)";
+}
+
+# die gracefully
+exit(0);
+
+#############################################################################
+##
+## OpenPKG RPM Package Specification Parsing
+##
+#############################################################################
+
+# escape XML for output in RDF file
sub e ($) {
- my($s) = @_;
- my($i);
+ my ($s) = @_;
+ my ($i);
+ # remove trailing whitespace
$s =~ s/\n+$//sg;
$s =~ s/[^\S\n]+$//mg;
+ # remove common leading whitespace
$i = undef;
- while ($s =~ /^([^\S\n]+)/mg) {
- $i = $1 if !defined $i || length($1) < length($i);
+ while ($s =~ m/^([^\S\n]+)/mg) {
+ $i = $1 if (!defined($i) || (length($1) < length($i)));
}
+ $s =~ s/^\Q$i\E//mg if (defined($i));
- $s =~ s/^\Q$i\E//mg if defined $i;
+ # escape XML special characters
$s =~ s/&/&/sg;
$s =~ s/</</sg;
$s =~ s/>/>/sg;
@@ -70,250 +170,240 @@
return $s;
}
-my %attrname = (
- '==' => 'equ',
- '=' => 'equ',
- '>=' => 'geq',
- '=>' => 'geq',
- '<=' => 'leq',
- '=<' => 'leq',
- '>' => 'gt',
- '<' => 'lt'
-);
-my($opreg) = join '|',
- map {
- "\Q$_\E"
- } sort {
- length($b) <=> length($a) ||
- $b cmp $a
- } keys %attrname;
-
-sub make_resource ($) {
- my($s) = @_;
-
- if ($s =~ /(\S+)\s*($opreg)\s*(.*?)\s*$/o) {
- return {
- resource => $1,
- attrname => $attrname{$2},
- attrval => $3
+# make_resource closure
+sub gen_make_resource {
+ # generate operator regular expression
+ # (used in make_resource below)
+ my %attrname = (
+ '==' => 'equ',
+ '=' => 'equ',
+ '>=' => 'geq',
+ '=>' => 'geq',
+ '<=' => 'leq',
+ '=<' => 'leq',
+ '>' => 'gt',
+ '<' => 'lt'
+ );
+ my ($opreg) =
+ join '|',
+ map {
+ "\Q$_\E"
+ } sort {
+ length($b) <=> length($a)
+ || $b cmp $a
+ } keys(%attrname);
+
+ # return function which makes resource object
+ return sub ($) {
+ my ($s) = @_;
+
+ if ($s =~ m/(\S+)\s*($opreg)\s*(.*?)\s*$/o) {
+ return {
+ resource => $1,
+ attrname => $attrname{$2},
+ attrval => $3
+ }
}
- }
-
- return {
- resource => $s
- }
-}
+ else {
+ return {
+ resource => $s
+ }
+ }
+ };
+};
+# split string into array at comma seperator
+# (optioanlly map resource operators into resource objects)
sub commasep ($$) {
- my($k,$v) = @_;
+ my ($k, $v) = @_;
- if ($k =~ /^(NoSource)$/) {
+ if ($k =~ m/^(NoSource)$/) {
return split(/\s*,\s*/, $v);
} elsif ($k =~ /^(PreReq|BuildPreReq|Provides|Conflicts)$/) {
- return map { make_resource($_) }
+ return map { &$make_resource($_) }
split(/\s*,\s*/, $v);
}
-
return $v;
}
+# escape option string
sub optesc ($) {
- my($s) = @_;
-
- $s =~ s/([\x00-\x1f\x80-\xbf\s\%])/sprintf("%%%02x",ord($1))/eg;
+ my ($s) = @_;
+ $s =~ s/([\x00-\x1f\x80-\xbf\s\%])/sprintf("%%%02x", ord($1))/eg;
return $s;
}
+# variable substitution
sub vsub ($$) {
- my($var,$v) = @_;
+ my ($var, $v) = @_;
$v =~ s/\%\{([^}]+)\}/
exists $var->{$1} ? $var->{$1} : '%{'.$1.'}'/emg;
-
return $v;
}
+# Umgekehrte Polnische Notation (UPN)
+# Reverse Polish Notation (RPN)
+# << ( %{foo} == "yes" ) && ( ! %{bar} == "no" ) || ( %{baz} == "yes" )
+# >> %{foo} %{bar} ! && %{baz} ||
sub upn ($) {
- my($t) = @_;
- my(@tok) = $t =~ /(\(|\)|\&\&|\|\||\!|\S+)/g;
- my(@out,$op,$o);
- my(@save);
+ my ($t) = @_;
+ my (@tok);
+ my (@out, $op, $o);
+ my (@save);
+
+ # split string into tokens
+ @tok = ($t =~ m/(\(|\)|\&\&|\|\||\!|\S+)/g);
+ # iterate over all tokens
$op = [];
foreach (@tok) {
if ($_ eq '(') {
- push @save, $op;
+ push(@save, $op);
$op = [];
} elsif ($_ eq ')') {
- die "FATAL: unresolved operators in: @tok\n" if @$op;
- $op = pop @save
- or die "FATAL: parenthesis stack underflow in: @tok\n";
- while ($o = pop @$op) {
- push @out, $o->[0];
- last if $o->[1];
+ die "openpkg:index:FATAL: unresolved operators in: @tok\n" if
(@$op);
+ $op = pop(@save)
+ or die "openpkg:index:FATAL: unmatched closing parenthesis
in: @tok\n";
+ while ($o = pop(@$op)) {
+ push(@out, $o->[0]);
+ last if ($o->[1]);
}
} elsif ($_ eq '&&') {
- push @$op, [ '+', 1 ] ;
+ push(@$op, [ '+', 1 ]);
} elsif ($_ eq '||') {
- push @$op, [ '|', 1 ] ;
+ push(@$op, [ '|', 1 ]);
} elsif ($_ eq '!') {
- push @$op, [ '!', 0 ];
- } elsif (/^\%\{(\S*?)\}$/) {
- push @out, $1;
- while ($o = pop @$op) {
- push @out, $o->[0];
- last if $o->[1]; # binop
+ push(@$op, [ '!', 0 ]);
+ } elsif (m/^\%\{(\S*?)\}$/) {
+ push(@out, $1);
+ while ($o = pop(@$op)) {
+ push(@out, $o->[0]);
+ last if ($o->[1]); # binary operator
}
}
}
-
- return join (' ',@out);
+ return join (' ', @out);
}
-#
-# deduce external variables from description
-#
-# before openpkg-20021230
-#
+# deduce external variables from description
+# (backward compatibility for times before openpkg-20021230)
sub find_options ($) {
- my($descr) = @_;
+ my ($descr) = @_;
my $evar = {};
$descr =~ s/--define\s*'(\S+)\s*\%\{\1\}'/$evar->{$1} = '%{'.$1.'}',
''/sge;
return $evar;
}
-#
-# translate default section from spec-file
-# into a hash
-# %if/%ifdef/%define... are translated to #if/#ifdef/#define
-#
-# #defines are interpolated (correct ?)
-#
-# #if/#ifdef/... sections are stripped
-# result is the same as if all conditions evaluate false (!)
-#
-# all attributes are of the form key: value
-# repeated attributes are coalesced into a list
-#
+# translate default section from spec-file into a hash
+# - %if/%ifdef/%define... are translated to #/#ifdef/#define
+# - #defines are interpolated (correct ?)
+# - #if/#ifdef/... sections are stripped
+# result is the same as if all conditions evaluate false (!)
+# - all attributes are of the form key: value
+# - repeated attributes are coalesced into a list
+# hint: evar = expansion variables, ovar = option variables
sub package2data ($$) {
- my($s,$ovar) = @_;
- my(%evar,%var);
- my(@term, $term);
- my(%attr,%avar);
- my($l, $v, $cond, $d, $p);
- my($re,@defs);
+ my ($s, $ovar) = @_;
+ my (%evar, %var);
+ my (@term, $term);
+ my (%attr, %avar);
+ my ($l, $v, $cond, $d, $p);
+ my ($re, @defs);
- # combine multilines
+ # combine multilines (line continuation!)
$s =~ s/\\\n/ /sg;
- #
- # map conditional variable macros
- #
+ # map syntax of conditional variable macros
$s =~ s/^#\{\!\?([^:]*):\s*%(.*?)\s*\}\s*$/#ifndef $1\n#$2\n#endif/mg;
$s =~ s/^#\{\!\?([^:]*):\s*(.*?)\s*\}\s*$/#ifndef $1\n$2\n#endif/mg;
- #
- # map option macro
- #
+ # map syntax of option macro
$s =~ s/^#option\s+(\S+)\s*(.*?)\s*$/#ifndef $1\n#define $1
$2\n#endif\n#provides $1 $2/mg;
- #
- # use option variables for interpolation
- #
+ # use option variables for expansion
%evar = %$ovar;
- #
- # guess more external parameters by scanning for "default" sections.
- #
+ # guess more external parameters by scanning for (and removing) "set
option default" sections
$re = '^\#ifndef\s+[\w\_]+\s*\n((?:\#define\s+[\w\_]+\s.*\n)+)\#endif\n';
- @defs = $s =~ /$re/gm;
+ @defs = ($s =~ m/$re/gm);
foreach (@defs) {
- while (/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
+ while (m/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
$ovar->{$1} = $2;
$evar{$1} = '%{'.$1.'}';
}
}
$s =~ s/$re//gm;
- #
- # add everything looking like a with_ variable
- #
+ # add everything looking like a "with_xxx" variable
$re = '%{(with\_[\w\_]+)}';
- @defs = $s =~ /$re/gm;
+ @defs = ($s =~ /$re/gm);
foreach (@defs) {
- next if exists $ovar->{$1};
- $ovar->{$1} = '%{'.$1.'}';
+ next if (exists($ovar->{$1}));
+ $ovar->{$1} = '%{'.$1.'}'; # unexpanded
$evar{$1} = '%{'.$1.'}';
}
- #
- # extract all conditional sections
- #
+ # extract all conditional sections (#if/#else/#endif)
@term = ();
%var = ();
$cond = '';
foreach $l (split(/\n/, $s)) {
+ # expand variables
$v = vsub(\%avar, vsub(\%var, $l));
if (($p) = $v =~ /^\#if\s+(.*?)\s*$/) {
- #
- # normalize #if expressions
- # "%{variable}" == "yes"
- # "%{variable}" == "no"
- # operators ! && ||
- #
+ # normalize #if expressions
+ # - "%{variable}" == "yes"
+ # - "%{variable}" == "no"
+ # - operators ! && ||
+ # warn on:
+ # - operator !=
+ # - any other word
$term = '';
- while ($p =~
/(!=)|(\!|\|\||\&\&|\(|\))|"\%\{([^}]+)\}"\s*==\s*"(yes|no)"|(\S+)/g) {
- if (defined $1) {
- warn "WARNING: unknown token '$1':\n< $l\n> $v\n";
- } elsif (defined $5) {
- warn "WARNING: unknown token '$5':\n< $l\n> $v\n";
- } elsif (defined $2) {
+ while ($p =~
m/(!=)|(\!|\|\||\&\&|\(|\))|"\%\{([^}]+)\}"\s*==\s*"(yes|no)"|(\S+)/g) {
+ if (defined($1)) {
+ warn "openpkg:index:WARNING: unknown token '$1':\n<
$l\n> $v"; # FIXME
+ } elsif (defined($5)) {
+ warn "openpkg:index:WARNING: unknown token '$5':\n<
$l\n> $v";
+ } elsif (defined($2)) {
$term .= " $2 ";
- } elsif (exists $evar{$3}) {
- $term .= ($4 eq 'no' ? '! ' :
'').vsub(\%evar,'%{'.$3.'}');
+ } elsif (exists($evar{$3})) {
+ $term .= ($4 eq 'no' ? '! ' : '').vsub(\%evar,
'%{'.$3.'}');
} else {
- warn "WARNING: unknown conditional '$3':\n< $l\n> $v\n";
+ warn "openpkg:index:WARNING: unknown condition variable
'$3':\n< $l\n> $v";
}
}
- #
- # join with previous conditions for this #if/#endif block
- #
+ # join with previous conditions for this #if/#endif block
if ($term ne '') {
- push @term, "( $term )";
- $cond = join(' && ', grep { $_ ne '' } @term).'';
+ push(@term, "( $term )");
+ $cond = join(' && ', grep { $_ ne '' } @term) . '';
} else {
- push @term, '';
+ push(@term, '');
}
- } elsif ($v =~ /^\#else\s*$/) {
- #
- # reverse last condition
- #
+ }
+ elsif ($v =~ /^\#else\s*$/) {
+ # reverse last condition
if (@term) {
- $term[-1] = ' ! '.$term[-1];
- $cond = join(' && ', grep { $_ ne '' } @term).'';
+ $term[-1] = ' ! '. $term[-1];
+ $cond = join(' && ', grep { $_ ne '' } @term) . '';
} else {
- die "FATAL: else without if\n";
+ die "openpkg:index:FATAL: \"else\" without \"if\"";
}
- } elsif ($v =~ /^\#endif\s*$/) {
- #
- # unwind last #if expression
- #
- pop @term;
- $cond = join(' && ', grep { $_ ne '' } @term).'';
-
- } elsif ($v =~ /^\#(?:define)\s*(\S+)\s*(.*?)\s*$/) {
-
- #
- # define conditional variables
- # truth-value becomes current condition
- #
- # define internal variables
- # -> store for subsequent substitution
- #
- if (exists $evar{$1}) {
+ }
+ elsif ($v =~ /^\#endif\s*$/) {
+ # unwind last #if expression
+ pop(@term);
+ $cond = join(' && ', grep { $_ ne '' } @term) . '';
+ }
+ elsif ($v =~ /^\#(?:define)\s*(\S+)\s*(.*?)\s*$/) {
+ # define conditional variables
+ # - truth-value becomes current condition
+ # define internal variables
+ # - store for subsequent substitution
+ if (exists($evar{$1})) {
if ($2 eq 'yes') {
if ($cond eq '') {
$evar{$1} = "( \%\{$1\} )";
@@ -327,98 +417,98 @@
$evar{$1} = "( %\{$1\} && ! ( $cond ) )";
}
} else {
- warn "WARNING: logic too complex for '$1':\n< $l\n>
$v\n";
+ warn "openpkg:index:WARNING: logic too complex for '$1'
(boolean expressions allowed only):\n< $l\n> $v";
}
} else {
$var{$1} = $2;
}
- } elsif ($v =~ /^\#(?:undefine)\s*(\S+)\s*$/) {
- if (exists $evar{$1}) {
+ }
+ elsif ($v =~ /^\#(?:undefine)\s*(\S+)\s*$/) {
+ # undefine conditional variables
+ # undefine internal variables
+ if (exists($evar{$1})) {
$evar{$1} = "\%\{$1\}";
} else {
- delete $var{$1};
+ delete($var{$1});
}
- } elsif ($v =~ /^\#(?:provides)\s*(\S+)\s*(.*?)\s*$/) {
- #
- # store option for current condition
- #
- if (exists $attr{'Name'}->{''}) {
- push @{$attr{'Provides'}->{$cond}}, {
- resource => $attr{'Name'}->{''}->[0].'::'.$1,
+ }
+ elsif ($v =~ /^\#(?:provides)\s*(\S+)\s*(.*?)\s*$/) {
+ # store option for current condition
+ if (exists($attr{'Name'}->{''})) {
+ push(@{$attr{'Provides'}->{$cond}}, {
+ resource => $attr{'Name'}->{''}->[0] . '::' . $1,
attrname => 'equ',
attrval => optesc($2)
- }
+ });
} else {
- warn "ERROR: no package name set for option $1 = $2\n";
+ warn "openpkg:index:ERROR: no package name set for option
\"$1 = $2\"";
}
-
- } elsif ($v =~ /^\#NoSource\s*(.*?)\s*$/) {
- #
- # store conditional NoSource attribute
- #
- push @{$attr{'NoSource'}->{$cond}}, commasep('NoSource',$1);
-
- } elsif ($v =~ /^\s*([^\#]\S*)\s*:\s*(.*?)\s*$/) {
- #
- # store attribute=value for current condition
- #
- push @{$attr{$1}->{$cond}}, commasep($1,$2);
- $avar{lc($1)} = $2 if $cond eq '';
+ }
+ elsif ($v =~ /^\#NoSource\s*(.*?)\s*$/) {
+ # store conditional NoSource attribute
+ push(@{$attr{'NoSource'}->{$cond}}, commasep('NoSource', $1));
+
+ }
+ elsif ($v =~ /^\s*([^\#]\S*)\s*:\s*(.*?)\s*$/) {
+ # store "attribute: value" headers for current condition
+ push(@{$attr{$1}->{$cond}}, commasep($1,$2));
+ $avar{lc($1)} = $2 if ($cond eq '');
}
}
+ # return all header "attributes"
return \%attr;
}
-#
-# split spec file into sections starting with a %word
-#
-# concatenate extended lines
-# strip comment lines
-# map %command to #command
-# split sections
-#
-# return package2data from default section.
-#
+# split spec file into sections starting with a %word
+# - concatenate extended lines
+# - strip comment lines
+# - map %command to #command
+# - split sections
+# - return package2data() from default section (before first %xxx section)
sub spec2data ($) {
- my($s) = @_;
- my(%map);
- my($a,$o);
+ my ($s) = @_;
+ my (%map);
+ my ($a, $o);
my $spec = $s;
- # remove comments
+ # remove comments
$s =~ s/^\s*#.*?\n//mg;
- # map commands
+ # map commands
$s =~
s/^%(ifdef|ifndef|if|NoSource|option|undefine|define|else|endif|\{)/#$1/mg;
- # split sections
- foreach (split(/^(?=%\w+\s*\n)/m, $s)) {
- if (/^%(\w+)\s*\n/) {
+ # split sections
+ foreach (split(m/^(?=%\w+\s*\n)/m, $s)) {
+ if (m/^%(\w+)\s*\n/) {
$map{$1} .= $';
} else {
$map{'*'} .= $_;
}
}
- if (exists $map{'description'}) {
+ # translate package information into "data"
+ if (exists($map{'description'})) {
+ # backward compatibility (options are in description)
$o = find_options($map{'description'});
$a = package2data($map{'*'}, $o );
$a->{'Description'} = { '' => [ $map{'description'} ] };
} else {
+ # standard case
$a = package2data($map{'*'}, {});
}
-
return $a;
}
-##########################################################################
+#############################################################################
+##
+## XML/RDF Generation
+##
+#############################################################################
-#
-# start of XML file
-#
+# start of XML file
sub xml_head ($$) {
- my($fh,$res) = @_;
+ my ($fh, $res) = @_;
print $fh <<EOFEOF;
<?xml version="1.0" encoding="iso-8859-1"?>
<rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#";
@@ -427,9 +517,7 @@
EOFEOF
}
-#
-# end of XML file, corresponds with start tags
-#
+# end of XML file, corresponds with start tags
sub xml_foot ($) {
my($fh) = @_;
print $fh <<EOFEOF;
@@ -438,80 +526,67 @@
EOFEOF
}
+# FIXME: ??
sub n($$) {
- my($a,$k) = @_;
- return unless $a->{$k};
- return unless $a->{$k}->{''};
- return $a->{$k}->{''}->[0];
+ my ($a, $k) = @_;
+ return if (not $a->{$k});
+ return if (not $a->{$k}->{''});
+ return ($a->{$k}->{''}->[0]);
}
-#
-# send out $a->{$k} as text-style tag
-#
+# send out $a->{$k} as text-style tag
sub xml_text ($$$;$) {
- my($i,$a,$k,$tag) = @_;
- my($out);
- return "" unless exists $a->{$k};
- $tag = $k unless defined $tag;
+ my ($i, $a, $k, $tag) = @_;
+ my ($out);
+ return "" if (not exists($a->{$k}));
+ $tag = $k if (not defined($tag));
$i = ' ' x $i;
-
$out = e(n($a,$k));
-
return if $out eq '';
-
return "$i<$tag>\n$out\n$i</$tag>\n";
}
-#
-# send out @{$a->{$k}} as body of an XML tag
-# $k is the name of the tag unless overridden by $tag
-# $i denotes the depth of indentation to form nicely
-# looking files.
-#
-# all data from the list is flattened into a single
-# body, separated by LF and escaped for XML metachars.
-#
+# send out @{$a->{$k}} as body of an XML tag
+# $k is the name of the tag unless overridden by $tag
+# $i denotes the depth of indentation to form nicely
+# looking files.
+# all data from the list is flattened into a single
+# body, separated by LF and escaped for XML metachars.
sub xml_tag ($$$;$) {
- my($i,$a,$k,$tag) = @_;
- my($out,$cond,$upn);
- return "" unless exists $a->{$k};
- $tag = $k unless defined $tag;
+ my ($i, $a, $k, $tag) = @_;
+ my ($out, $cond, $upn);
+ return "" if (not exists($a->{$k}));
+ $tag = $k if (not defined($tag));
$out = '';
$i = ' ' x $i;
-
- foreach $cond (sort keys %{$a->{$k}}) {
+ foreach $cond (sort keys(%{$a->{$k}})) {
$upn = e(upn($cond));
- $out .= $i.
- ($cond ne '' ? "<$tag cond=\"$upn\">" : "<$tag>").
- join("\n", map { e($_) } @{$a->{$k}->{$cond}}).
+ $out .= $i .
+ ($cond ne '' ? "<$tag cond=\"$upn\">" : "<$tag>") .
+ join("\n", map { e($_) } @{$a->{$k}->{$cond}}) .
"</$tag>\n";
}
-
return $out;
}
-#
-# send out @{$a->{$k}} as a rdf:bag
-# $k is the name of the outer tag unless overriden by $tag
-# $i denotes the depth of indentation, inner tags are indented
-# 2 or 4 more character positions.
-#
-# each element of the bag is listed
-#
+# send out @{$a->{$k}} as a rdf:bag
+# $k is the name of the outer tag unless overriden by $tag
+# $i denotes the depth of indentation, inner tags are indented
+# 2 or 4 more character positions.
+# each element of the bag is listed
sub xml_bag ($$$;$) {
- my($i,$a,$k,$tag) = @_;
- my($out,$cond,$upn);
- return "" unless exists $a->{$k};
- $tag = $k unless defined $tag;
+ my ($i, $a, $k, $tag) = @_;
+ my ($out, $cond, $upn);
+ return "" if (not exists($a->{$k}));
+ $tag = $k if (not defined($tag));
$out = '';
$i = ' ' x $i;
-
foreach $cond (sort keys %{$a->{$k}}) {
- next unless @{$a->{$k}->{$cond}};
+ next if (not @{$a->{$k}->{$cond}});
$upn = e(upn($cond));
- $out .= $i.
- ($cond ne '' ? "<$tag cond=\"$upn\">\n" : "<$tag>\n").
- "$i <rdf:bag>\n".
+ $out .= $i .
+ ($cond ne '' ? "<$tag cond=\"$upn\">\n" : "<$tag>\n") .
+ "$i <rdf:bag>\n" .
join("",
map {
ref $_
@@ -519,133 +594,121 @@
( exists $_->{attrname}
? " $_->{attrname}=\"".e($_->{attrval})."\""
: ""
- ).
+ ) .
">".e($_->{resource})."</resource>\n"
: "$i <rdf:li>".e($_)."</rdf:li>\n"
}
- @{$a->{$k}->{$cond}}).
- "$i </rdf:bag>\n".
+ @{$a->{$k}->{$cond}}) .
+ "$i </rdf:bag>\n" .
"$i</$tag>\n";
}
-
return $out;
}
-#
-# send out reference to another RDF
-#
+# send out reference to another RDF
sub xml_reference ($$$) {
my($fh, $res, $href) = @_;
-
print $fh <<EOFEOF;
<Repository rdf:resource="$res" href="$href"/>
EOFEOF
}
-#
-# translate attributes from %$a as generated by package2data
-# into XML and write to file $fh
-#
+# translate attributes from %$a as generated by package2data
+# into XML and write to file $fh
sub xml_record ($$$) {
- my($fh, $a, $href) = @_;
- my($maj,$min,$rel,$about);
+ my ($fh, $a, $href) = @_;
+ my ($maj, $min, $rel, $about);
$about =
- n($a,'Name').'-'.
- n($a,'Version').'-'.
+ n($a,'Name') . '-' .
+ n($a,'Version') . '-' .
n($a,'Release');
-
- unless (defined $href) {
-
- # guess location from Information in Specfile
-
- if (exists $a->{'NoSource'}) {
+ if (not defined($href)) {
+ # guess location from Information in Specfile
+ if (exists($a->{'NoSource'})) {
$href = "$about.nosrc.rpm";
} else {
$href = "$about.src.rpm";
}
- ($maj,$min,$rel) = n($a,'Release') =~ /^(\d+)\.(\d+)\.(\d+)/;
-
- if (defined $min) {
+ ($maj, $min, $rel) = (n($a, 'Release') =~ m/^(\d+)\.(\d+)\.(\d+)/);
+ if (defined($min)) {
if ($maj > 1 || ($maj == 1 && $min > 0)) {
- # 1.1 or later
+ # OpenPKG-1.1-RELEASE or later
if (n($a,'Distribution') =~ /\[PLUS\]/) {
$href = 'PLUS/'.$href;
}
}
if ($maj > 1 || ($maj == 1 && $min >= 0)) {
- # 1.0 or later
+ # OpenPKG-1.0-RELEASE or later
if ($rel > 0) {
$href = 'UPD/'.$href;
}
}
} else {
- # current
+ # OpenPKG-CURRENT
}
-
}
print $fh <<EOFEOF;
<rdf:Description about="$about" href="$href">
EOFEOF
- # fake Source attribute from Source\d attribtutes
- # XXX only default conditional
+ # fake Source attribute from Source\d attribtutes
+ # XXX only default conditional
$a->{'Source'} = { '' => [
map {
- s/\Q%{name}\E/n($a,'Name')/esg;
- s/\Q%{version}\E/n($a,'Version')/esg;
- s/\Q%{release}\E/n($a,'Release')/esg;
- #s/.*\///;
+ s/\Q%{name}\E/n($a, 'Name')/esg;
+ s/\Q%{version}\E/n($a, 'Version')/esg;
+ s/\Q%{release}\E/n($a, 'Release')/esg;
$_;
}
map {
$a->{$_}->{''} ? @{$a->{$_}->{''}} : ()
}
sort {
- my($x) = $a =~ /^(\d*)$/;
- my($y) = $b =~ /^(\d*)$/;
+ my ($x) = ($a =~ /^(\d*)$/);
+ my ($y) = ($b =~ /^(\d*)$/);
return $x <=> $y;
}
grep {
/^Source\d*$/
- } keys %$a
+ } keys(%$a)
]};
- delete $a->{'Source'} unless @{$a->{'Source'}->{''}};
+ delete($a->{'Source'}) if (not @{$a->{'Source'}->{''}});
print $fh
- xml_tag(6, $a, 'Name'),
- xml_tag(6, $a, 'Version'),
- xml_tag(6, $a, 'Release'),
- xml_tag(6, $a, 'Distribution'),
- xml_tag(6, $a, 'Class'),
- xml_tag(6, $a, 'Group'),
- xml_tag(6, $a, 'License'),
- xml_tag(6, $a, 'Packager'),
- xml_tag(6, $a, 'Summary'),
- xml_tag(6, $a, 'URL'),
- xml_tag(6, $a, 'Vendor'),
- xml_tag(6, $a, 'SourceRPM'),
- xml_tag(6, $a, 'Arch'),
- xml_tag(6, $a, 'Os'),
- xml_tag(6, $a, 'BuildHost'),
- xml_tag(6, $a, 'BuildSystem'),
- xml_tag(6, $a, 'BuildTime'),
- xml_tag(6, $a, 'Relocations'),
- xml_tag(6, $a, 'Size'),
- xml_tag(6, $a, 'Prefixes'),
- xml_tag(6, $a, 'Platform'),
- xml_tag(6, $a, 'SigSize'),
- xml_tag(6, $a, 'SigMD5'),
- xml_tag(6, $a, 'SigPGP'),
- xml_tag(6, $a, 'SigGPG'),
- xml_bag(6, $a, 'BuildPreReq'),
- xml_bag(6, $a, 'PreReq'),
- xml_bag(6, $a, 'Provides'),
- xml_bag(6, $a, 'Conflicts'),
- xml_bag(6, $a, 'Source'),
- xml_bag(6, $a, 'NoSource'),
- xml_bag(6, $a, 'Filenames'),
+ xml_tag(6, $a, 'Name'),
+ xml_tag(6, $a, 'Version'),
+ xml_tag(6, $a, 'Release'),
+ xml_tag(6, $a, 'Distribution'),
+ xml_tag(6, $a, 'Class'),
+ xml_tag(6, $a, 'Group'),
+ xml_tag(6, $a, 'License'),
+ xml_tag(6, $a, 'Packager'),
+ xml_tag(6, $a, 'Summary'),
+ xml_tag(6, $a, 'URL'),
+ xml_tag(6, $a, 'Vendor'),
+ xml_tag(6, $a, 'SourceRPM'),
+ xml_tag(6, $a, 'Arch'),
+ xml_tag(6, $a, 'Os'),
+ xml_tag(6, $a, 'BuildHost'),
+ xml_tag(6, $a, 'BuildSystem'),
+ xml_tag(6, $a, 'BuildTime'),
+ xml_tag(6, $a, 'Relocations'),
+ xml_tag(6, $a, 'Size'),
+ xml_tag(6, $a, 'Prefixes'),
+ xml_tag(6, $a, 'Platform'),
+ xml_tag(6, $a, 'SigSize'),
+ xml_tag(6, $a, 'SigMD5'),
+ xml_tag(6, $a, 'SigPGP'),
+ xml_tag(6, $a, 'SigGPG'),
+ xml_bag(6, $a, 'BuildPreReq'),
+ xml_bag(6, $a, 'PreReq'),
+ xml_bag(6, $a, 'Provides'),
+ xml_bag(6, $a, 'Conflicts'),
+ xml_bag(6, $a, 'Source'),
+ xml_bag(6, $a, 'NoSource'),
+ xml_bag(6, $a, 'Filenames'),
xml_text(6, $a, 'Description');
print $fh <<EOFEOF;
@@ -653,28 +716,32 @@
EOFEOF
}
-#####################################################################
+#############################################################################
+##
+## OpenPKG RPM Package Payload Extraction
+##
+#############################################################################
+# extract foo.spec from foo-V-R.src.rpm file
sub rpm2spec ($) {
- my($fn) = @_;
+ my ($fn) = @_;
local($SIG{'PIPE'}) = 'IGNORE';
- my($pipe) = new FileHandle "$R2C '$fn' |"
- or die "FATAL: cannot read '$fn' ($!)\n";
- my($buf,@hdr,$n,$m,$name,$step);
- my($spec);
-
- while (read($pipe,$buf,110) == 110) {
- @hdr = unpack('a6a8a8a8a8a8a8a8a8a8a8a8a8a8',$buf);
+ my ($pipe) = new FileHandle "$R2C '$fn' |"
+ or die "openpkg:index:FATAL: cannot read '$fn' ($!)\n";
+ my ($buf, @hdr, $n, $m, $name, $step);
+ my ($spec);
+ while (read($pipe, $buf, 110) == 110) {
+ @hdr = unpack('a6a8a8a8a8a8a8a8a8a8a8a8a8a8', $buf);
$n = hex($hdr[12]); # filename length
$m = int(($n+5)/4)*4-2; # filename size (padded)
- last unless read($pipe,$buf,$m) == $m;
- $name = substr($buf,0,$n-1);
+ last if (not (read($pipe,$buf,$m) == $m));
+ $name = substr($buf, 0, $n-1);
$n = hex($hdr[7]); # file length
$m = int(($n+3)/4)*4; # file size (padded)
- if ($name !~ /.spec$/) {
+ if ($name !~ m/.spec$/) {
while ($m > 0) {
$step = $m > 8192 ? 8192 : $m;
- last unless read($pipe,$buf,$step);
+ last if (not read($pipe,$buf,$step));
$m -= length($buf);
}
} else {
@@ -685,19 +752,23 @@
}
}
$pipe->close;
-
return $spec;
}
-#####################################################################
+#############################################################################
+##
+## OpenPKG RPM Package Header Extraction
+##
+#############################################################################
+# extract header information from foo-V-R.src.rpm
sub rpm2data ($$) {
- my($fn,$platform) = @_;
- my($q,$pipe,%a);
- my($t,$v);
+ my ($fn, $platform) = @_;
+ my ($q, $pipe, %a);
+ my ($t, $v);
- unless (defined $platform) {
- die "FATAL: indexing binary package '$fn' requires -p option\n";
+ if (not defined($platform)) {
+ die "openpkg:index:FATAL: indexing binary package '$fn' requires -p
option\n";
}
$q = <<EOFEOF;
@@ -746,14 +817,13 @@
$t = $1;
$v = $2;
} elsif (/^(\s+.+?)\s*$/) {
- next unless defined $t;
+ next if (not defined($t));
$v = $1;
} else {
$t = undef;
next;
}
-
- if (exists $a{$t}) {
+ if (exists($a{$t})) {
$a{$t} .= "\n$v";
} else {
$a{$t} = $v;
@@ -763,21 +833,21 @@
%a = map { $_ => $a{$_} }
grep { $a{$_} ne '(none)' }
- keys %a;
+ keys(%a);
if ($a{'Relocations'} eq '(non relocatable)') {
- delete $a{'Relocations'};
+ delete($a{'Relocations'});
}
if ($a{'SigMD5'} eq '(unknown type)') {
- delete $a{'SigMD5'};
+ delete($a{'SigMD5'});
}
- if (defined $platform) {
+ if (defined($platform)) {
$a{'Platform'} = $platform;
}
$a{'Description'} = [ $a{'Description'} ];
foreach ('Conflicts', 'PreReq', 'Provides') {
$a{$_} = [
- map { make_resource($_) }
+ map { &$make_resource($_) }
grep { !/^rpmlib\(/ }
split(/\n+/, $a{$_})
];
@@ -785,89 +855,102 @@
return { map {
$_ => { '' => (ref $a{$_} ? $a{$_} : [ split(/\n+/, $a{$_}) ]) }
- } keys %a };
+ } keys(%a) };
}
-#####################################################################
+#############################################################################
+##
+## OpenPKG XML/RDF Index Locating
+##
+#############################################################################
+# detect index files
sub getindex ($) {
- my($dir) = @_;
- my(@idx) = sort { -M $a <=> -M $b; }
- grep { -f $_ }
- ( <$dir/00INDEX.rdf>, <$dir/00INDEX.rdf.*> );
-
- return unless @idx;
+ my ($dir) = @_;
+ my (@idx) =
+ sort { -M $a <=> -M $b; }
+ grep { -f $_ }
+ ( <$dir/00INDEX.rdf>, <$dir/00INDEX.rdf.*> );
+ return if (not @idx);
return $idx[0];
}
+# list RPM directories of unpacked .spec files
sub list_specdir ($) {
- my($dir) = @_;
- my($dh,$d,$path);
- my(@list);
+ my ($dir) = @_;
+ my ($dh, $d, $path);
+ my (@list);
$dh = new DirHandle($dir);
while ($d = $dh->read) {
- next if $d =~ /^\./;
+ next if ($d =~ m/^\./);
$path = "$dir/$d/$d.spec";
- push @list, $path if -f $path;
+ push(@list, $path) if (-f $path);
}
-
return [EMAIL PROTECTED];
}
+# list index or RPM file directories
sub list_rpmdir ($) {
my($dir) = @_;
- my($dh,$d,$path);
- my(@list,$idx,$sub);
+ my($dh, $d, $path);
+ my(@list, $idx, $sub);
$dh = new DirHandle($dir);
while ($d = $dh->read) {
- next if $d =~ /^\./;
+ next if ($d =~ m/^\./);
$path = "$dir/$d";
if (-d $path) {
$idx = getindex($path);
- if (defined $idx) {
- push @list, $idx;
+ if (defined($idx)) {
+ push(@list, $idx);
} else {
$sub = list_rpmdir($path);
- push @list, @$sub;
+ push(@list, @$sub);
undef $sub;
}
} else {
- next unless $d =~ /\.rpm$/ && -f $path;
- push @list, $path;
+ next if (not ($d =~ m/\.rpm$/ && -f $path));
+ push(@list, $path);
}
}
-
return [EMAIL PROTECTED];
}
-#####################################################################
+#############################################################################
+##
+## OpenPKG XML/RDF Index Reading
+##
+#############################################################################
+# fetch a whole file
sub readfile ($) {
- my($fn) = @_;
- my($fh) = new FileHandle "< $fn"
+ my ($fn) = @_;
+ my ($fh) = new FileHandle "< $fn"
or die "FATAL: cannot read '$fn' ($!)\n";
- my(@l) = <$fh>;
+ my (@l) = <$fh>; # FIXME: optimize
$fh->close;
- return join('',@l);
+ return join('', @l);
}
+# create relative path by stripping instance prefix
sub relpath ($$) {
- my($prefix,$path) = @_;
+ my ($prefix, $path) = @_;
$path =~ s/^\Q$prefix\E\///s;
return $path;
}
+# create directory path with trailing slash
sub dirname ($) {
- my($path) = @_;
+ my ($path) = @_;
$path =~ s/\/[^\/]*$//s;
return $path.'/';
}
+# peek at resource identifier of index file
sub getresource ($) {
- my($fn) = @_;
- my($fh, $buf);
+ my ($fn) = @_;
+ my ($fh, $buf);
if ($fn =~ /\.bz2$/) {
$fh = new FileHandle "$BZ -dc $fn |"
@@ -878,127 +961,70 @@
}
$fh->read($buf, 1024);
$fh->close;
-
if ($buf =~ /<Repository.*?rdf:resource="([^"]+)"/) {
return $1;
}
-
return undef;
}
-#####################################################################
+#############################################################################
+##
+## OpenPKG XML/RDF Index Output Generation
+##
+#############################################################################
sub write_index ($$$$$$) {
- my($fh,$prefix,$resource,$platform,$list,$cache) = @_;
- my($a,$h,$r,$spec);
- my($mtime);
+ my ($fh, $prefix, $resource, $platform, $list, $cache) = @_;
+ my ($a, $h, $r, $spec);
+ my ($mtime);
foreach (@$list) {
$a = undef;
$h = undef;
$r = undef;
- if (/\.spec$/) {
+
+ # determine information
+ if (m/\.spec$/) {
$spec = readfile($_);
$a = spec2data($spec);
- } elsif (/([^\/]+\.(?:no)?src\.rpm)$/) {
- $h = relpath($prefix, $_);
+ } elsif (m/([^\/]+\.(?:no)?src\.rpm)$/) {
+ $h = relpath($prefix, $_);
if ($cache) {
- $mtime = (stat $_)[9];
- if (exists $cache->{"M$_"} &&
- $cache->{"M$_"} == $mtime) {
+ $mtime = (stat($_))[9];
+ if ( exists($cache->{"M$_"})
+ && $cache->{"M$_"} == $mtime) {
+ # found in cache
$spec = $cache->{"S$_"};
} else {
+ # not found in cache
$spec = rpm2spec($_);
$cache->{"S$_"} = $spec;
$cache->{"M$_"} = $mtime;
}
} else {
+ # no cache at all
$spec = rpm2spec($_);
}
- $a = spec2data($spec);
- } elsif (/([^\/]+\.rpm)$/) {
- $h = relpath($prefix, $_);
- $a = rpm2data($_, $platform);
- } elsif (/([^\/]+\.rdf[^\/]*)$/) {
- $h = relpath($prefix, $_);
- $r = getresource($_) || $resource.dirname($h);
+ $a = spec2data($spec);
+ } elsif (m/([^\/]+\.rpm)$/) {
+ $h = relpath($prefix, $_);
+ $a = rpm2data($_, $platform);
+ } elsif (m/([^\/]+\.rdf[^\/]*)$/) {
+ $h = relpath($prefix, $_);
+ $r = getresource($_) || $resource.dirname($h);
}
+ # process information
if ($a) {
xml_record($fh, $a, $h);
} elsif ($r) {
xml_reference($fh, $r, $h);
} else {
- warn "ERROR: cannot process $_\n";
+ warn "openpkg:index:ERROR: cannot process $_";
}
}
}
-#####################################################################
-
-my($prefix,$list,$fh,%cache,$tmpo);
-
-if ($#ARGV < 0) {
- print "openpkg:index:USAGE: $0 [-r resource] [-p platform] [-C cache.db]
[-o index.rdf] [-c] [-i] dir ...\n";
- exit(1);
-}
-
-if ($opt_C) {
- eval {
- require DB_File;
- };
- if ($@) {
- die "Sorry. The -C option requires an installed DB_File perl
module.\n";
- }
- tie %cache, 'DB_File', $opt_C, O_CREAT|O_RDWR, 0666, $DB_File::DB_HASH
- or die "FATAL: cannot tie cache '$opt_C' ($!)\n";
-}
-
-$opt_r = 'OpenPKG-CURRENT/Source/' unless defined $opt_r;
-
-if (defined $opt_o) {
- $tmpo = $opt_o . '.tmp';
- if ($opt_c) {
- $fh = new FileHandle "| $BZ -c > '$tmpo'"
- or die "FATAL: cannot write '$tmpo' ($!)\n";
- } else {
- $fh = new FileHandle "> $tmpo"
- or die "FATAL: cannot write '$tmpo' ($!)\n";
- }
-} else {
- if ($opt_c) {
- $fh = new FileHandle "| $BZ -c"
- or die "FATAL: cannot write to stdout ($!)\n";
- } else {
- $fh = new FileHandle ">&=1"
- or die "FATAL: cannot write to stdout ($!)\n";
- }
-}
-
-xml_head($fh, $opt_r);
-foreach $prefix (@ARGV) {
- if (-d $prefix) {
- if ($opt_i) {
- $list = list_rpmdir($prefix);
- } else {
- $list = list_specdir($prefix);
- }
- } else {
- $list = [ $prefix ];
- $prefix = dirname($prefix);
- }
- write_index($fh, $prefix, $opt_r, $opt_p, $list, $opt_C ? \%cache :
undef);
-}
-xml_foot($fh);
-
-$fh->close
- or die "FATAL: write error on output ($!)\n";
-
-if (defined $tmpo) {
- rename $tmpo,$opt_o
- or die "FATAL: cannot rename $tmpo to $opt_o ($!)\n";
-}
-
__END__
=pod
@@ .
______________________________________________________________________
The OpenPKG Project www.openpkg.org
CVS Repository Commit List [email protected]
