diff -r 71503088f51b -r f880f219c566 openpkg/index.pl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/openpkg/index.pl Tue Jul 31 12:23:42 2012 +0200
@@ -0,0 +1,1173 @@
+##
+## index.pl -- OpenPKG Maintenance Tool (backend for indexing)
+## Copyright (c) 2000-2012 OpenPKG GmbH
+##
+## This software is property of the OpenPKG GmbH, DE MUC HRB 160208.
+## All rights reserved. Licenses which grant limited permission to use,
+## copy, modify and distribute this software are available from the
+## OpenPKG GmbH.
+##
+## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED
+## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
+## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
+## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+## SUCH DAMAGE.
+##
+
+#############################################################################
+##
+## MAIN PROCEDURE
+##
+#############################################################################
+
+require 5;
+#use strict;
+
+# 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:index: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";
+my $OPENSSL = "$l_prefix/lib/openpkg/openssl";
+
+# parse command line
+our ($opt_r, $opt_p, $opt_S, $opt_T, $opt_D, $opt_C, $opt_o, $opt_c, $opt_i);
+my $getopts = 'r:p:STDC:o:ci';
+getopts($getopts);
+if ($#ARGV < 0) {
+ print "openpkg:index:USAGE: openpkg index [-r resource] [-p platform] [-S] [-T] [-D] [-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.";
+ }
+ eval {
+ require Fcntl;
+ };
+ if ($@) {
+ die "openpkg:index:FATAL: The -C option requires an installed Fcntl perl module.";
+ }
+ tie %cache, 'DB_File', $opt_C, Fcntl::O_CREAT()|Fcntl::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) {
+ open(FH, "| $BZ -c > '$tmpo'")
+ or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
+ } else {
+ open(FH, "> $tmpo")
+ or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
+ }
+} else {
+ if ($opt_c) {
+ open(FH, "| $BZ -c")
+ or die "openpkg:index:FATAL: cannot write to stdout ($!)";
+ } else {
+ open(FH, ">&=1")
+ or die "openpkg:index:FATAL: cannot write to stdout ($!)";
+ }
+}
+$fh = \*FH;
+
+# 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);
+
+# close output channel
+close($fh)
+ 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);
+
+#############################################################################
+##
+## FUNCTIONS: PARSING
+##
+#############################################################################
+
+# home-brewn getopt(3) style option parser
+sub getopts ($) {
+ my ($opts) = @_;
+ my (%optf) = map { m/(\w)/; $1 => $_ } $opts =~ m/(\w:|\w)/g;
+ my (%opts, @argv, $optarg);
+
+ foreach (@ARGV) {
+ if (@argv) {
+ push @argv, $_;
+ } elsif (defined $optarg) {
+ if (exists $opts{$optarg}) {
+ $opts{$optarg} .= " $_";
+ } else {
+ $opts{$optarg} = $_;
+ }
+ $optarg = undef;
+ } elsif (!/^[-]/) {
+ push @argv, $_;
+ } else {
+ while (/^\-(\w)(.*)/) {
+ if (exists $optf{$1}) {
+ if (length($optf{$1}) > 1) {
+ if ($2 ne '') {
+ if (exists $opts{$1}) {
+ $opts{$1} .= " $2";
+ } else {
+ $opts{$1} = $2;
+ }
+ } else {
+ $optarg = $1;
+ }
+ last;
+ } else {
+ $opts{$1} = 1;
+ }
+ } else {
+ warn "openpkg:index:WARNING: unknown option $_\n";
+ }
+ $_ = "-$2";
+ }
+ }
+ }
+ if (defined $optarg) {
+ warn "openpkg:index:WARNING: option $optarg requires an argument\n";
+ }
+ foreach (keys %opts) {
+ eval '$opt_'.$_.' = "'.quotemeta($opts{$_}).'";';
+ }
+ @ARGV = @argv;
+}
+
+#############################################################################
+##
+## OpenPKG RPM Package Specification Parsing
+##
+#############################################################################
+
+# escape XML for output in RDF file
+sub e ($) {
+ my ($s) = @_;
+ my ($i);
+
+ # remove trailing whitespace
+ $s =~ s/\n+$//sg;
+ $s =~ s/[^\S\n]+$//mg;
+
+ # remove common leading whitespace
+ $i = undef;
+ while ($s =~ m/^([^\S\n]+)/mg) {
+ $i = $1 if (!defined($i) || (length($1) < length($i)));
+ }
+ $s =~ s/^\Q$i\E//mg if (defined($i));
+
+ # escape XML special characters
+ $s =~ s/&/&/sg;
+ $s =~ s//>/sg;
+
+ return $s;
+}
+
+# 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
+ }
+ }
+ else {
+ return {
+ resource => $s
+ }
+ }
+ };
+};
+
+# split string into array at comma seperator
+# (optioanlly map resource operators into resource objects)
+sub commasep ($$) {
+ my ($k, $v) = @_;
+
+ if ($k =~ m/^(NoSource)$/) {
+ return split(/\s*,\s*/, $v);
+ } elsif ($k =~ /^(PreReq|BuildPreReq|Provides|Conflicts)$/) {
+ 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;
+ return $s;
+}
+
+# variable substitution
+sub vsub ($$) {
+ 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);
+ 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);
+ $op = [];
+ } elsif ($_ eq ')') {
+ 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 ]);
+ } elsif ($_ eq '||') {
+ push(@$op, [ '|', 1 ]);
+ } elsif ($_ eq '!') {
+ 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);
+}
+
+# deduce external variables from description
+# (backward compatibility for times before openpkg-20021230)
+sub find_options ($) {
+ 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 #/#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);
+
+ # combine multilines (line continuation!)
+ $s =~ s/\\\n/ /sg;
+
+ # 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 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 expansion
+ %evar = %$ovar;
+
+ # 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 =~ m/$re/gm);
+ foreach (@defs) {
+ while (m/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
+ $ovar->{$1} = $2;
+ $evar{$1} = '%{'.$1.'}';
+ }
+ }
+ $s =~ s/$re//gm;
+
+ # add everything looking like a "with_xxx" variable
+ $re = '%{(with\_[\w\_]+)}';
+ @defs = ($s =~ /$re/gm);
+ foreach (@defs) {
+ next if (exists($ovar->{$1}));
+ $ovar->{$1} = '%{'.$1.'}'; # unexpanded
+ $evar{$1} = '%{'.$1.'}';
+ }
+
+ # 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 "%{variable}" != ..."
+ $p =~ s/("\%\{[^}]+\}")\s*!=\s*"(yes|no)"/$1 . " == \"" . ($2 ne "yes" ? "yes" : "no") . "\""/sge;
+
+ # normalize #if expressions
+ # - "%{variable}" == "yes"
+ # - "%{variable}" == "no"
+ # - operators ! && ||
+ # warn on:
+ # - operator !=
+ # - any other word
+ $term = '';
+ while ($p =~ m/(!=)|(\!|\|\||\&\&|\(|\))|"\%\{([^}]+)\}"\s*==\s*"(yes|no)"|(\S+)/g) {
+ if (defined($1)) {
+ warn "openpkg:index:WARNING: unknown token '$1':\n< $l\n> $v";
+ } 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.'}');
+ } else {
+ warn "openpkg:index:WARNING: unknown condition variable '$3':\n< $l\n> $v";
+ }
+ }
+
+ # join with previous conditions for this #if/#endif block
+ if ($term ne '') {
+ push(@term, "( $term )");
+ $cond = join(' && ', grep { $_ ne '' } @term) . '';
+ } else {
+ push(@term, '');
+ }
+ }
+ elsif ($v =~ /^\#else\s*$/) {
+ # reverse last condition
+ if (@term) {
+ $term[-1] = ' ! '. $term[-1];
+ $cond = join(' && ', grep { $_ ne '' } @term) . '';
+ } else {
+ 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})) {
+ if ($2 eq 'yes') {
+ if ($cond eq '') {
+ $evar{$1} = "( \%\{$1\} )";
+ } else {
+ $evar{$1} = "( \%\{$1\} || ( $cond ) )";
+ }
+ } elsif ($2 eq 'no') {
+ if ($cond eq '') {
+ $evar{$1} = "( \%\{$1\} )";
+ } else {
+ $evar{$1} = "( %\{$1\} && ! ( $cond ) )";
+ }
+ } else {
+ 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*$/) {
+ # undefine conditional variables
+ # undefine internal variables
+ if (exists($evar{$1})) {
+ $evar{$1} = "\%\{$1\}";
+ } else {
+ 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,
+ attrname => 'equ',
+ attrval => optesc($2)
+ });
+ } else {
+ 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" 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 (before first %xxx section)
+sub spec2data ($) {
+ my ($s) = @_;
+ my (%map);
+ my ($a, $o);
+ my $spec = $s;
+
+ # remove comments
+ $s =~ s/^\s*#.*?\n//mg;
+
+ # map commands
+ $s =~ s/^%(ifdef|ifndef|if|NoSource|option|undefine|define|else|endif|\{)/#$1/mg;
+
+ # split sections
+ foreach (split(m/^(?=%\w+\s*\n)/m, $s)) {
+ if (m/^%(\w+)\s*\n/) {
+ $map{$1} .= $';
+ } else {
+ $map{'*'} .= $_;
+ }
+ }
+
+ # 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
+sub xml_head ($$) {
+ my ($fh, $res) = @_;
+ print $fh <
+
+
+EOFEOF
+}
+
+# end of XML file, corresponds with start tags
+sub xml_foot ($) {
+ my($fh) = @_;
+ print $fh <
+
+EOFEOF
+}
+
+# conditional expansion of attribute
+sub n ($$) {
+ 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
+sub xml_text ($$$;$) {
+ 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\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.
+sub xml_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}})) {
+ $upn = e(upn($cond));
+ $out .= $i .
+ ($cond ne '' ? "<$tag cond=\"$upn\">" : "<$tag>") .
+ join("\n", map { e($_) } @{$a->{$k}->{$cond}}) .
+ "\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
+sub xml_bag ($$$;$) {
+ 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 if (not @{$a->{$k}->{$cond}});
+ $upn = e(upn($cond));
+ $out .= $i .
+ ($cond ne '' ? "<$tag cond=\"$upn\">\n" : "<$tag>\n") .
+ "$i \n" .
+ join("",
+ map {
+ ref $_
+ ? "$i {attrname}
+ ? " $_->{attrname}=\"".e($_->{attrval})."\""
+ : ""
+ ) .
+ ">".e($_->{resource})."\n"
+ : "$i ".e($_)."\n"
+ }
+ @{$a->{$k}->{$cond}}) .
+ "$i \n" .
+ "$i\n";
+ }
+ return $out;
+}
+
+# send out reference to another RDF
+sub xml_reference ($$$$$$) {
+ my($fh, $res, $href, $S, $T, $D) = @_;
+ print $fh " \n";
+}
+
+# send out reference to other resources
+sub xml_other ($$$$$$) {
+ my($fh, $about, $href, $S, $T, $D) = @_;
+ print $fh " \n";
+ print $fh " \n";
+}
+
+# translate attributes from %$a as generated by package2data
+# into XML and write to file $fh
+sub xml_record ($$$$$$) {
+ my ($fh, $a, $href, $S, $T, $D) = @_;
+ my ($maj, $min, $rel, $about);
+
+ $about =
+ n($a, 'Name') . '-' .
+ n($a, 'Version') . '-' .
+ n($a, 'Release');
+ 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') =~ m/^(\d+)\.(\d+)\.(\d+)/);
+ if (defined($min)) {
+ if ($maj > 1 || ($maj == 1 && $min > 0)) {
+ # OpenPKG-1.1-RELEASE or later
+ if (n($a, 'Distribution') =~ /\[PLUS\]/) {
+ $href = 'PLUS/'.$href;
+ }
+ }
+ if ($maj > 1 || ($maj == 1 && $min >= 0)) {
+ # OpenPKG-1.0-RELEASE or later
+ if ($rel > 0) {
+ $href = 'UPD/'.$href;
+ }
+ }
+ } else {
+ # OpenPKG-CURRENT
+ }
+ }
+
+ print $fh " \n";
+
+ # 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;
+ $_;
+ }
+ map {
+ $a->{$_}->{''} ? @{$a->{$_}->{''}} : ()
+ }
+ sort {
+ my ($x) = ($a =~ /^(\d*)$/);
+ my ($y) = ($b =~ /^(\d*)$/);
+ return $x <=> $y;
+ }
+ grep {
+ /^Source\d*$/
+ } keys(%$a)
+ ]};
+ 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_text(6, $a, 'Description');
+
+ print $fh " \n";
+}
+
+#############################################################################
+##
+## OpenPKG RPM Package Payload Extraction
+##
+#############################################################################
+
+# extract foo.spec from foo-V-R.src.rpm file
+sub rpm2spec ($) {
+ my ($fn) = @_;
+ local($SIG{'PIPE'}) = 'IGNORE';
+ local(*PIPE);
+ open(PIPE, "$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 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 !~ m/.spec$/) {
+ while ($m > 0) {
+ $step = $m > 8192 ? 8192 : $m;
+ last if (not read(PIPE,$buf,$step));
+ $m -= length($buf);
+ }
+ } else {
+ if (read(PIPE,$buf,$n) == $n) {
+ $spec = $buf;
+ }
+ last;
+ }
+ }
+ close(PIPE);
+ return $spec;
+}
+
+#############################################################################
+##
+## OpenPKG RPM Package Header Extraction
+##
+#############################################################################
+
+# extract header information from foo-V-R.src.rpm
+sub rpm2data ($$) {
+ my ($fn, $platform) = @_;
+ my ($q, %a);
+ my ($t, $v);
+ local(*PIPE);
+
+ if (not defined($platform)) {
+ die "openpkg:index:FATAL: indexing binary package '$fn' requires -p option\n";
+ }
+
+ $q = <) {
+ if (/^(\S+)\s+(.*?)\s*$/) {
+ $t = $1;
+ $v = $2;
+ } elsif (/^(\s+.+?)\s*$/) {
+ next if (not defined($t));
+ $v = $1;
+ } else {
+ $t = undef;
+ next;
+ }
+ if (exists($a{$t})) {
+ $a{$t} .= "\n$v";
+ } else {
+ $a{$t} = $v;
+ }
+ }
+ close(PIPE);
+
+ %a = map { $_ => $a{$_} }
+ grep { $a{$_} ne '(none)' }
+ keys(%a);
+ if ($a{'Relocations'} eq '(non relocatable)') {
+ delete($a{'Relocations'});
+ }
+ if ($a{'SigMD5'} eq '(unknown type)') {
+ delete($a{'SigMD5'});
+ }
+ if (defined($platform)) {
+ $a{'Platform'} = $platform;
+ }
+ $a{'Description'} = [ $a{'Description'} ];
+
+ foreach ('Conflicts', 'PreReq', 'Provides') {
+ $a{$_} = [
+ map { &$make_resource($_) }
+ grep { !/^rpmlib\(/ }
+ split(/\n+/, $a{$_})
+ ];
+ }
+
+ return { map {
+ $_ => { '' => (ref $a{$_} ? $a{$_} : [ split(/\n+/, $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 if (not @idx);
+ return $idx[0];
+}
+
+# list RPM directories of unpacked .spec files
+sub list_specdir ($) {
+ my ($dir) = @_;
+ my ($d, $path);
+ my (@list);
+
+ local(*DH);
+ opendir(DH, $dir);
+ while ($d = readdir(DH)) {
+ next if ($d =~ m/^\./);
+ $path = "$dir/$d/$d.spec";
+ push(@list, $path) if (-f $path);
+ }
+ closedir(DH);
+ return \@list;
+}
+
+# list index or RPM file directories
+sub list_rpmdir ($) {
+ my ($dir) = @_;
+ my ($d, $path);
+ my (@list, $idx, $sub);
+
+ local(*DH);
+ opendir(DH, $dir);
+ while ($d = readdir(DH)) {
+ next if ($d =~ m/^\./);
+ $path = "$dir/$d";
+ if (-d $path) {
+ $idx = getindex($path);
+ if (defined($idx)) {
+ push(@list, $idx);
+ } else {
+ $sub = list_rpmdir($path);
+ push(@list, @$sub);
+ undef $sub;
+ }
+ } else {
+ next if (not ($d =~ m/\.(?:rpm|sh)$/ && -f $path));
+ push(@list, $path);
+ }
+ }
+ closedir(DH);
+ return \@list;
+}
+
+#############################################################################
+##
+## OpenPKG XML/RDF Index Reading
+##
+#############################################################################
+
+# fetch a whole file
+sub readfile ($) {
+ my ($fn) = @_;
+ local(*FH);
+ open(FH, "< $fn")
+ or die "FATAL: cannot read '$fn' ($!)\n";
+ my $l; { local $/; $l = ; }
+ close(FH);
+ return $l;
+}
+
+# create relative path by stripping instance prefix
+sub relpath ($$) {
+ my ($prefix, $path) = @_;
+ $path =~ s/^\Q$prefix\E\///s;
+ return $path;
+}
+
+# create directory path with trailing slash
+sub dirname ($) {
+ my ($path) = @_;
+ $path =~ s/\/[^\/]*$//s;
+ return $path.'/';
+}
+
+# peek at resource identifier of index file
+sub getresource ($) {
+ my ($fn) = @_;
+ my ($fh, $buf);
+
+ local(*FH);
+ if ($fn =~ /\.bz2$/) {
+ open(FH, "$BZ -dc $fn |")
+ or die "FATAL: cannot read '$fn' ($!)\n";
+ } else {
+ open(FH, "< $fn")
+ or die "FATAL: cannot read '$fn' ($!)\n";
+ }
+ read(FH, $buf, 1024);
+ close(FH);
+ if ($buf =~ //dev/null || true`;
+ if ($output =~ m/MD5\(.+?\)=\s*([0-9a-fA-F]+)/s) {
+ $digest = uc($1);
+ }
+ return $digest;
+}
+
+sub write_index ($$$$$$) {
+ my ($fh, $prefix, $resource, $platform, $list, $cache) = @_;
+ my ($a, $h, $r, $spec, $T, $D);
+
+ foreach (@$list) {
+ $a = undef;
+ $h = undef;
+ $r = undef;
+ $S = undef;
+ $T = undef;
+ $D = undef;
+ $o = undef;
+
+ # determine information
+ if (m/\.spec$/) {
+ $spec = readfile($_);
+ $a = spec2data($spec);
+ ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
+ $D = digest($_) if ($opt_D);
+ } elsif (m/([^\/]+\.(?:no)?src\.rpm)$/) {
+ $h = relpath($prefix, $_);
+ ($S, $T) = sizetime($_) if ($opt_S or $opt_T or $cache);
+ if ($cache) {
+ if ( exists($cache->{"T$_"})
+ && $cache->{"T$_"} == $T
+ && exists($cache->{"s$_"})
+ && $cache->{"s$_"} ne ""
+ && (!$opt_S || ($opt_S && exists($cache->{"S$_"}) && $cache->{"S$_"} ne ""))
+ && (!$opt_D || ($opt_D && exists($cache->{"D$_"}) && $cache->{"D$_"} ne ""))) {
+ # found in cache
+ $spec = $cache->{"s$_"};
+ $S = $cache->{"S$_"} if ($opt_S);
+ $D = $cache->{"D$_"} if ($opt_D);
+ } else {
+ # not found in cache
+ $spec = rpm2spec($_);
+ $cache->{"s$_"} = $spec;
+ $cache->{"S$_"} = $S;
+ $cache->{"T$_"} = $T;
+ $D = digest($_) if ($opt_D);
+ $cache->{"D$_"} = $D if ($opt_D);
+ }
+ } else {
+ # no cache at all
+ $spec = rpm2spec($_);
+ $D = digest($_) if ($opt_D);
+ }
+ $a = spec2data($spec);
+ } elsif (m/([^\/]+\.rpm)$/) {
+ $h = relpath($prefix, $_);
+ $a = rpm2data($_, $platform);
+ ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
+ $D = digest($_) if ($opt_D);
+ } elsif (m/(([^\/]+)\.(?:no)?src\.sh)$/) {
+ $h = relpath($prefix, $_);
+ ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
+ $D = digest($_) if ($opt_D);
+ $o = "$2:bootstrap";
+ } elsif (m/([^\/]+\.rdf[^\/]*)$/) {
+ $h = relpath($prefix, $_);
+ $r = getresource($_) || $resource.dirname($h);
+ ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
+ $D = digest($_) if ($opt_D);
+ }
+
+ # process information
+ if ($a) {
+ xml_record($fh, $a, $h, $S, $T, $D);
+ } elsif ($o) {
+ xml_other($fh, $o, $h, $S, $T, $D);
+ } elsif ($r) {
+ xml_reference($fh, $r, $h, $S, $T, $D);
+ } else {
+ warn "openpkg:index:ERROR: cannot process $_";
+ }
+ }
+}
+