|
|
@@ -0,0 +1,866 @@
|
|
|
+##
|
|
|
+## openpkg-index -- create index from spec files
|
|
|
+##
|
|
|
+## Copyright (c) 2000-2002 Cable & Wireless Deutschland GmbH
|
|
|
+## Copyright (c) 2000-2002 The OpenPKG Project <http://www.openpkg.org/>
|
|
|
+## Copyright (c) 2000-2002 Ralf S. Engelschall <rse@engelschall.com>
|
|
|
+##
|
|
|
+## Permission to use, copy, modify, and distribute this software for
|
|
|
+## any purpose with or without fee is hereby granted, provided that
|
|
|
+## the above copyright notice and this permission notice appear in all
|
|
|
+## copies.
|
|
|
+##
|
|
|
+## 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.
|
|
|
+##
|
|
|
+
|
|
|
+require 5;
|
|
|
+
|
|
|
+use strict;
|
|
|
+
|
|
|
+use Getopt::Std;
|
|
|
+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 $RPM = 'rpm';
|
|
|
+my $R2C = 'rpm2cpio';
|
|
|
+my $BZ = 'bzip2 -9';
|
|
|
+
|
|
|
+#########################################################################
|
|
|
+
|
|
|
+#
|
|
|
+# escape XML special characters for output in RDF file
|
|
|
+#
|
|
|
+# remove trailing whitespace
|
|
|
+# remove common leading whitespace
|
|
|
+#
|
|
|
+sub e ($) {
|
|
|
+ my($s) = @_;
|
|
|
+ my($i);
|
|
|
+
|
|
|
+ $s =~ s/\n+$//sg;
|
|
|
+ $s =~ s/\s+$//mg;
|
|
|
+
|
|
|
+ $i = undef;
|
|
|
+ while ($s =~ /^(\s+)/mg) {
|
|
|
+ $i = $1 if !defined $i || length($1) < length($i);
|
|
|
+ }
|
|
|
+
|
|
|
+ $s =~ s/^\Q$i\E//mg if defined $i;
|
|
|
+ $s =~ s/&/&/sg;
|
|
|
+ $s =~ s/</</sg;
|
|
|
+ $s =~ s/>/>/sg;
|
|
|
+
|
|
|
+ return $s;
|
|
|
+}
|
|
|
+
|
|
|
+sub commasep ($$) {
|
|
|
+ my($k,$v) = @_;
|
|
|
+
|
|
|
+ if ($k =~ /^(PreReq|BuildPreReq|Provides|Conflicts)$/) {
|
|
|
+ return split(/\s*,\s*/, $v);
|
|
|
+ }
|
|
|
+
|
|
|
+ return $v;
|
|
|
+}
|
|
|
+
|
|
|
+sub vsub ($$) {
|
|
|
+ my($var,$v) = @_;
|
|
|
+
|
|
|
+ $v =~ s/\%\{([^}]+)\}/exists $var->{$1} ? $var->{$1} : '%{'.$1.'}'/emg;
|
|
|
+
|
|
|
+ return $v;
|
|
|
+}
|
|
|
+
|
|
|
+sub upn ($) {
|
|
|
+ my($t) = @_;
|
|
|
+ my(@tok) = $t =~ /(\(|\)|\&\&|\|\||\!|\S+)/g;
|
|
|
+ my(@out,$op,$o);
|
|
|
+ my(@save);
|
|
|
+
|
|
|
+ $op = [];
|
|
|
+ foreach (@tok) {
|
|
|
+ if ($_ eq '(') {
|
|
|
+ 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];
|
|
|
+ }
|
|
|
+ } elsif ($_ eq '&&') {
|
|
|
+ push @$op, [ '+', 1 ] ;
|
|
|
+ } elsif ($_ eq '||') {
|
|
|
+ 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
|
|
|
+ }
|
|
|
+ }
|
|
|
+ }
|
|
|
+
|
|
|
+ return join (' ',@out);
|
|
|
+}
|
|
|
+
|
|
|
+#
|
|
|
+# deduce external variables from description
|
|
|
+#
|
|
|
+sub find_options ($) {
|
|
|
+ my($descr) = @_;
|
|
|
+ my(%evar);
|
|
|
+
|
|
|
+ %evar = map {
|
|
|
+ $1 => '%{'.$1.'}'
|
|
|
+ } $descr =~ /--define\s*'(\S+)\s*\%\{\1\}'/;
|
|
|
+
|
|
|
+ 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
|
|
|
+#
|
|
|
+sub package2data ($$) {
|
|
|
+ my($s,$evar) = @_;
|
|
|
+ my(%var);
|
|
|
+ my(@term, $term);
|
|
|
+ my(%attr);
|
|
|
+ my($l, $v, $cond, $d, $p);
|
|
|
+ my($re,@defs);
|
|
|
+
|
|
|
+ # combine multilines
|
|
|
+ $s =~ s/\\\n/ /sg;
|
|
|
+
|
|
|
+ #
|
|
|
+ # map 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;
|
|
|
+
|
|
|
+ #
|
|
|
+ # guess more external parameters by scanning for "default" sections.
|
|
|
+ #
|
|
|
+ $re = '^\#ifndef\s+[\w\_]+\s*\n((?:\#define\s+[\w\_]+\s.*\n)+)\#endif\n';
|
|
|
+ @defs = $s =~ /$re/gm;
|
|
|
+ foreach (@defs) {
|
|
|
+ while (/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
|
|
|
+ $evar->{$1} = '%{'.$1.'}';
|
|
|
+ }
|
|
|
+ }
|
|
|
+ $s =~ s/$re//gm;
|
|
|
+
|
|
|
+ #
|
|
|
+ # add everything looking like a with_ variable
|
|
|
+ #
|
|
|
+ $re = '%{(with\_[\w\_]+)}';
|
|
|
+ @defs = $s =~ /$re/gm;
|
|
|
+ foreach (@defs) {
|
|
|
+ $evar->{$1} = '%{'.$1.'}';
|
|
|
+ }
|
|
|
+
|
|
|
+
|
|
|
+ #
|
|
|
+ # extract all conditional sections
|
|
|
+ #
|
|
|
+ @term = ();
|
|
|
+ %var = ();
|
|
|
+ $cond = '';
|
|
|
+ foreach $l (split(/\n/, $s)) {
|
|
|
+ $v = vsub(\%var,$l);
|
|
|
+
|
|
|
+ if (($p) = $v =~ /^\#if\s+(.*?)\s*$/) {
|
|
|
+ #
|
|
|
+ # normalize #if expressions
|
|
|
+ # "%{variable}" == "yes"
|
|
|
+ # "%{variable}" == "no"
|
|
|
+ # operators ! && ||
|
|
|
+ #
|
|
|
+ $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) {
|
|
|
+ $term .= " $2 ";
|
|
|
+ } elsif (exists $evar->{$3}) {
|
|
|
+ $term .= ($4 eq 'no' ? '! ' : '').vsub($evar,'%{'.$3.'}');
|
|
|
+ } else {
|
|
|
+ warn "WARNING: unknown conditional '$2':\n< $l\n> $v\n";
|
|
|
+ }
|
|
|
+ }
|
|
|
+
|
|
|
+ #
|
|
|
+ # 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 "FATAL: else without if\n";
|
|
|
+ }
|
|
|
+ } 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') {
|
|
|
+ $evar->{$1} = "( \%\{$1\} || ( $cond ) )";
|
|
|
+ } elsif ($2 eq 'no') {
|
|
|
+ $evar->{$1} = "( %\{$1\} && ! ( $cond ) )";
|
|
|
+ } else {
|
|
|
+ warn "WARNING: logic too complex for '$1':\n< $l\n> $v\n";
|
|
|
+ }
|
|
|
+ } else {
|
|
|
+ $var{$1} = $2;
|
|
|
+ }
|
|
|
+ } elsif ($v =~ /^\s*([^\#]\S*)\s*:\s*(.*?)\s*$/) {
|
|
|
+
|
|
|
+ #
|
|
|
+ # store attribute=value for current condition
|
|
|
+ #
|
|
|
+ push @{$attr{$1}->{$cond}}, commasep($1,$2);
|
|
|
+ }
|
|
|
+ }
|
|
|
+
|
|
|
+ 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.
|
|
|
+#
|
|
|
+sub spec2data ($) {
|
|
|
+ my($s) = @_;
|
|
|
+ my(%map);
|
|
|
+ my($a,$o);
|
|
|
+
|
|
|
+ # remove comments
|
|
|
+ $s =~ s/^\s*#.*?\n//mg;
|
|
|
+
|
|
|
+ # map commands
|
|
|
+ $s =~ s/^%(ifdef|ifndef|if|define|else|endif|\{)/#$1/mg;
|
|
|
+
|
|
|
+ # split sections
|
|
|
+ foreach (split(/^(?=%\w+\s*\n)/m, $s)) {
|
|
|
+ if (/^%(\w+)\s*\n/) {
|
|
|
+ $map{$1} .= $';
|
|
|
+ } else {
|
|
|
+ $map{'*'} .= $_;
|
|
|
+ }
|
|
|
+ }
|
|
|
+
|
|
|
+ $o = find_options($map{'description'});
|
|
|
+ $a = package2data($map{'*'}, $o);
|
|
|
+ if (exists $map{'description'}) {
|
|
|
+ $a->{'Description'} = { '' => [ $map{'description'} ] };
|
|
|
+ }
|
|
|
+
|
|
|
+ return $a;
|
|
|
+}
|
|
|
+
|
|
|
+##########################################################################
|
|
|
+
|
|
|
+#
|
|
|
+# start of XML file
|
|
|
+#
|
|
|
+sub xml_head ($$) {
|
|
|
+ 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#"
|
|
|
+ xmlns="http://www.openpkg.org/xml-rdf-index/0.9">
|
|
|
+ <Repository rdf:resource="$res">
|
|
|
+EOFEOF
|
|
|
+}
|
|
|
+
|
|
|
+#
|
|
|
+# end of XML file, corresponds with start tags
|
|
|
+#
|
|
|
+sub xml_foot ($) {
|
|
|
+ my($fh) = @_;
|
|
|
+ print $fh <<EOFEOF;
|
|
|
+ </Repository>
|
|
|
+</rdf:RDF>
|
|
|
+EOFEOF
|
|
|
+}
|
|
|
+
|
|
|
+sub n($$) {
|
|
|
+ my($a,$k) = @_;
|
|
|
+ return unless $a->{$k};
|
|
|
+ return unless $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 "" unless exists $a->{$k};
|
|
|
+ $tag = $k unless 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.
|
|
|
+#
|
|
|
+sub xml_tag ($$$;$) {
|
|
|
+ my($i,$a,$k,$tag) = @_;
|
|
|
+ my($out,$cond,$upn);
|
|
|
+ return "" unless exists $a->{$k};
|
|
|
+ $tag = $k unless 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}}).
|
|
|
+ "</$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.
|
|
|
+#
|
|
|
+sub xml_bag ($$$;$) {
|
|
|
+ my($i,$a,$k,$tag) = @_;
|
|
|
+ my($out,$cond,$upn);
|
|
|
+ return "" unless exists $a->{$k};
|
|
|
+ $tag = $k unless defined $tag;
|
|
|
+ $out = '';
|
|
|
+ $i = ' ' x $i;
|
|
|
+
|
|
|
+ foreach $cond (sort keys %{$a->{$k}}) {
|
|
|
+ $upn = e(upn($cond));
|
|
|
+ $out .= $i.
|
|
|
+ ($cond ne '' ? "<$tag cond=\"$upn\">\n" : "<$tag>\n").
|
|
|
+ "$i <rdf:bag>\n".
|
|
|
+ join("",
|
|
|
+ map { "$i <rdf:li>".e($_)."</rdf:li>\n" }
|
|
|
+ @{$a->{$k}->{$cond}}).
|
|
|
+ "$i </rdf:bag>\n".
|
|
|
+ "$i</$tag>\n";
|
|
|
+ }
|
|
|
+
|
|
|
+ return $out;
|
|
|
+}
|
|
|
+
|
|
|
+#
|
|
|
+# 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
|
|
|
+#
|
|
|
+sub xml_record ($$$) {
|
|
|
+ my($fh, $a, $href) = @_;
|
|
|
+ my($maj,$min,$rel,$about);
|
|
|
+
|
|
|
+ $about =
|
|
|
+ n($a,'Name').'-'.
|
|
|
+ n($a,'Version').'-'.
|
|
|
+ n($a,'Release');
|
|
|
+
|
|
|
+ unless (defined $href) {
|
|
|
+
|
|
|
+ # guess location from Information in Specfile
|
|
|
+
|
|
|
+ $href = "$about.src.rpm";
|
|
|
+ ($maj,$min,$rel) = n($a,'Release') =~ /^(\d+)\.(\d+)\.(\d+)/;
|
|
|
+
|
|
|
+ if (defined $min) {
|
|
|
+ if ($maj > 1 || ($maj == 1 && $min > 0)) {
|
|
|
+ # 1.1 or later
|
|
|
+ if (n($a,'Distribution') =~ /\[PLUS\]/) {
|
|
|
+ $href = 'PLUS/'.$href;
|
|
|
+ }
|
|
|
+ }
|
|
|
+ if ($maj > 1 || ($maj == 1 && $min >= 0)) {
|
|
|
+ # 1.0 or later
|
|
|
+ if ($rel > 0) {
|
|
|
+ $href = 'UPD/'.$href;
|
|
|
+ }
|
|
|
+ }
|
|
|
+ } else {
|
|
|
+ # current
|
|
|
+ }
|
|
|
+
|
|
|
+ }
|
|
|
+
|
|
|
+ print $fh <<EOFEOF;
|
|
|
+ <rdf:Description about="$about" href="$href">
|
|
|
+EOFEOF
|
|
|
+
|
|
|
+ # 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/.*\///;
|
|
|
+ $_;
|
|
|
+ }
|
|
|
+ map {
|
|
|
+ $a->{$_}->{''} ? @{$a->{$_}->{''}} : ()
|
|
|
+ }
|
|
|
+ sort {
|
|
|
+ my($x) = $a =~ /^(\d*)$/;
|
|
|
+ my($y) = $b =~ /^(\d*)$/;
|
|
|
+ return $x <=> $y;
|
|
|
+ }
|
|
|
+ grep {
|
|
|
+ /^Source\d*$/
|
|
|
+ } keys %$a
|
|
|
+ ]};
|
|
|
+ delete $a->{'Source'} unless @{$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, '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, 'BuildRoot'),
|
|
|
+ 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, 'Filenames'),
|
|
|
+ xml_text(6, $a, 'Description');
|
|
|
+
|
|
|
+ print $fh <<EOFEOF;
|
|
|
+ </rdf:Description>
|
|
|
+EOFEOF
|
|
|
+}
|
|
|
+
|
|
|
+#####################################################################
|
|
|
+
|
|
|
+sub rpm2spec ($) {
|
|
|
+ my($fn) = @_;
|
|
|
+ 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);
|
|
|
+ $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);
|
|
|
+ $n = hex($hdr[7]); # file length
|
|
|
+ $m = int(($n+3)/4)*4; # file size (padded)
|
|
|
+ if ($name !~ /.spec$/) {
|
|
|
+ while ($m > 0) {
|
|
|
+ $step = $m > 8192 ? 8192 : $m;
|
|
|
+ last unless read($pipe,$buf,$step);
|
|
|
+ $m -= length($buf);
|
|
|
+ }
|
|
|
+ } else {
|
|
|
+ if (read($pipe,$buf,$n) == $n) {
|
|
|
+ $spec = $buf;
|
|
|
+ }
|
|
|
+ last;
|
|
|
+ }
|
|
|
+ }
|
|
|
+ $pipe->close;
|
|
|
+
|
|
|
+ return $spec;
|
|
|
+}
|
|
|
+
|
|
|
+#####################################################################
|
|
|
+
|
|
|
+sub rpm2data ($$) {
|
|
|
+ my($fn,$platform) = @_;
|
|
|
+ my($q,$pipe,%a);
|
|
|
+ my($t,$v);
|
|
|
+
|
|
|
+ $q = <<EOFEOF;
|
|
|
+Name %{Name}
|
|
|
+Version %{Version}
|
|
|
+Release %{Release}
|
|
|
+URL %{URL}
|
|
|
+Summary %{Summary}
|
|
|
+Copyright %{Copyright}
|
|
|
+License %{License}
|
|
|
+Distribution %{Distribution}
|
|
|
+Vendor %{Vendor}
|
|
|
+Group %{Group}
|
|
|
+Packager %{Packager}
|
|
|
+Prefixes %{Prefixes}
|
|
|
+BuildRoot %{BuildRoot}
|
|
|
+BuildHost %{BuildHost}
|
|
|
+BuildTime %{BuildTime}
|
|
|
+Arch %{Arch}
|
|
|
+Os %{Os}
|
|
|
+Size %{Size}
|
|
|
+SigSize %{SigSize}
|
|
|
+SigMD5 %{SigMD5}
|
|
|
+SigPGP %{SigPGP}
|
|
|
+SigGPG %{SigGPG}
|
|
|
+SourceRPM %{SourceRPM}
|
|
|
+[Patch %{Patch}
|
|
|
+]
|
|
|
+[Source %{Source}
|
|
|
+]
|
|
|
+[Filenames %{Filenames}
|
|
|
+]
|
|
|
+[Conflicts %{CONFLICTNAME} %|CONFLICTFLAGS?{%{CONFLICTFLAGS:depflags} %{CONFLICTVERSION}}:{}|
|
|
|
+]
|
|
|
+[PreReq %{REQUIRENAME} %|REQUIREFLAGS?{%{REQUIREFLAGS:depflags} %{REQUIREVERSION}}:{}|
|
|
|
+]
|
|
|
+[Provides %{PROVIDENAME} %|PROVIDEFLAGS?{%{PROVIDEFLAGS:depflags} %{PROVIDEVERSION}}:{}|
|
|
|
+]
|
|
|
+Description %{Description}
|
|
|
+EOFEOF
|
|
|
+
|
|
|
+ $pipe = new FileHandle "$RPM -qp --qf '$q' '$fn' |"
|
|
|
+ or die "FATAL: cannot read '$fn' ($!)\n";
|
|
|
+ while (<$pipe>) {
|
|
|
+ if (/^(\S+)\s+(.*?)\s*$/) {
|
|
|
+ $t = $1;
|
|
|
+ $v = $2;
|
|
|
+ } elsif (/^(\s+.+?)\s*$/) {
|
|
|
+ next unless defined $t;
|
|
|
+ $v = $1;
|
|
|
+ } else {
|
|
|
+ $t = undef;
|
|
|
+ next;
|
|
|
+ }
|
|
|
+
|
|
|
+ if (exists $a{$t}) {
|
|
|
+ $a{$t} .= "\n$v";
|
|
|
+ } else {
|
|
|
+ $a{$t} = $v;
|
|
|
+ }
|
|
|
+ }
|
|
|
+ $pipe->close;
|
|
|
+
|
|
|
+ %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'};
|
|
|
+ }
|
|
|
+ $a{'Platform'} = "$a{'Arch'}-$platform-$a{'Os'}";
|
|
|
+ $a{'PreReq'} =~ s/^rpmlib\(.*$//mg;
|
|
|
+ $a{'Description'} = [ $a{'Description'} ];
|
|
|
+
|
|
|
+ return { map {
|
|
|
+ $_ => { '' => (ref $a{$_} ? $a{$_} : [ split(/\n+/, $a{$_}) ]) }
|
|
|
+ } keys %a };
|
|
|
+}
|
|
|
+
|
|
|
+#####################################################################
|
|
|
+
|
|
|
+sub getindex ($) {
|
|
|
+ my($dir) = @_;
|
|
|
+ my(@idx) = sort { -M $a <=> -M $b; }
|
|
|
+ grep { -f $_ }
|
|
|
+ ( <$dir/00INDEX.rdf>, <$dir/00INDEX.rdf.*> );
|
|
|
+
|
|
|
+ return unless @idx;
|
|
|
+ return $idx[0];
|
|
|
+}
|
|
|
+
|
|
|
+sub list_specdir ($) {
|
|
|
+ my($dir) = @_;
|
|
|
+ my($dh,$d,$path);
|
|
|
+ my(@list);
|
|
|
+
|
|
|
+ $dh = new DirHandle($dir);
|
|
|
+ while ($d = $dh->read) {
|
|
|
+ next if $d =~ /^\./;
|
|
|
+ $path = "$dir/$d/$d.spec";
|
|
|
+ push @list, $path if -f $path;
|
|
|
+ }
|
|
|
+
|
|
|
+ return \@list;
|
|
|
+}
|
|
|
+
|
|
|
+sub list_rpmdir ($) {
|
|
|
+ my($dir) = @_;
|
|
|
+ my($dh,$d,$path);
|
|
|
+ my(@list,$idx,$sub);
|
|
|
+
|
|
|
+ $dh = new DirHandle($dir);
|
|
|
+ while ($d = $dh->read) {
|
|
|
+ next if $d =~ /^\./;
|
|
|
+ $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 unless $d =~ /\.rpm$/ && -f $path;
|
|
|
+ push @list, $path;
|
|
|
+ }
|
|
|
+ }
|
|
|
+
|
|
|
+ return \@list;
|
|
|
+}
|
|
|
+
|
|
|
+#####################################################################
|
|
|
+
|
|
|
+sub readfile ($) {
|
|
|
+ my($fn) = @_;
|
|
|
+ my($fh) = new FileHandle "< $fn"
|
|
|
+ or die "FATAL: cannot read '$fn' ($!)\n";
|
|
|
+ my(@l) = <$fh>;
|
|
|
+ $fh->close;
|
|
|
+ return join('',@l);
|
|
|
+}
|
|
|
+
|
|
|
+sub relpath ($$) {
|
|
|
+ my($prefix,$path) = @_;
|
|
|
+ $path =~ s/^\Q$prefix\E\///s;
|
|
|
+ return $path;
|
|
|
+}
|
|
|
+
|
|
|
+sub dirname ($) {
|
|
|
+ my($path) = @_;
|
|
|
+ $path =~ s/\/[^\/]*$//s;
|
|
|
+ return $path.'/';
|
|
|
+}
|
|
|
+
|
|
|
+sub getresource ($) {
|
|
|
+ my($fn) = @_;
|
|
|
+ my($fh, $buf);
|
|
|
+
|
|
|
+ if ($fn =~ /\.bz2$/) {
|
|
|
+ $fh = new FileHandle "$BZ -dc $fn |"
|
|
|
+ or die "FATAL: cannot read '$fn' ($!)\n";
|
|
|
+ } else {
|
|
|
+ $fh = new FileHandle "< $fn"
|
|
|
+ or die "FATAL: cannot read '$fn' ($!)\n";
|
|
|
+ }
|
|
|
+ $fh->read($buf, 1024);
|
|
|
+ $fh->close;
|
|
|
+
|
|
|
+ if ($buf =~ /<Repository.*?rdf:resource="([^"]+)"/) {
|
|
|
+ return $1;
|
|
|
+ }
|
|
|
+
|
|
|
+ return undef;
|
|
|
+}
|
|
|
+
|
|
|
+#####################################################################
|
|
|
+
|
|
|
+sub write_index ($$$$$$) {
|
|
|
+ my($fh,$prefix,$resource,$platform,$list,$cache) = @_;
|
|
|
+ my($a,$h,$r,$spec);
|
|
|
+ my($mtime);
|
|
|
+
|
|
|
+ foreach (@$list) {
|
|
|
+ $a = undef;
|
|
|
+ $h = undef;
|
|
|
+ $r = undef;
|
|
|
+ if (/\.spec$/) {
|
|
|
+ $spec = readfile($_);
|
|
|
+ $a = spec2data($spec);
|
|
|
+ } elsif (/([^\/]+\.src\.rpm)$/) {
|
|
|
+ $h = relpath($prefix, $_);
|
|
|
+ if ($cache) {
|
|
|
+ $mtime = (stat $_)[9];
|
|
|
+ if (exists $cache->{"M$_"} &&
|
|
|
+ $cache->{"M$_"} == $mtime) {
|
|
|
+ $spec = $cache->{"S$_"};
|
|
|
+ } else {
|
|
|
+ $spec = rpm2spec($_);
|
|
|
+ $cache->{"S$_"} = $spec;
|
|
|
+ $cache->{"M$_"} = $mtime;
|
|
|
+ }
|
|
|
+ } else {
|
|
|
+ $spec = rpm2spec($_);
|
|
|
+ }
|
|
|
+ $a = spec2data($spec);
|
|
|
+ } elsif (/([^\/]+\.rpm)$/) {
|
|
|
+ $h = relpath($prefix, $_);
|
|
|
+ $a = rpm2data($_, $platform);
|
|
|
+ } elsif (/([^\/]+\.rdf[^\/]*)$/) {
|
|
|
+ $h = relpath($prefix, $_);
|
|
|
+ $r = getresource($_) || $resource.dirname($h);
|
|
|
+ }
|
|
|
+
|
|
|
+ if ($a) {
|
|
|
+ xml_record($fh, $a, $h);
|
|
|
+ } elsif ($r) {
|
|
|
+ xml_reference($fh, $r, $h);
|
|
|
+ } else {
|
|
|
+ warn "ERROR: cannot process $_\n";
|
|
|
+ }
|
|
|
+ }
|
|
|
+}
|
|
|
+
|
|
|
+#####################################################################
|
|
|
+
|
|
|
+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";
|
|
|
+ die "\n";
|
|
|
+}
|
|
|
+
|
|
|
+if ($opt_C) {
|
|
|
+ require DB_File;
|
|
|
+ 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;
|
|
|
+$opt_p = 'unknown' unless defined $opt_p;
|
|
|
+
|
|
|
+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) {
|
|
|
+ die "FATAL: $prefix is not a directory\n" unless -d $prefix;
|
|
|
+ if ($opt_i) {
|
|
|
+ $list = list_rpmdir($prefix);
|
|
|
+ } else {
|
|
|
+ $list = list_specdir($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";
|
|
|
+}
|
|
|
+
|