OpenPKG Specs: openpkg/index.pl@a2c6460cfb16 (annotated)

openpkg/index.pl@a2c6460cfb16 (annotated)

openpkg/index.pl

Mon, 28 Jan 2013 17:37:18 +0100

author: Michael Schloh von Bennewitz <michael@schloh.com>
date: Mon, 28 Jan 2013 17:37:18 +0100
changeset 758: a2c6460cfb16
permissions: -rw-r--r--

Correct socket error reporting improvement with IPv6 portable code,
after helpful recommendation by Saúl Ibarra Corretgé on OSips devlist.

 ##
 ##  index.pl -- OpenPKG Maintenance Tool (backend for indexing)
 ##  Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/>
 ##
 ##  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/&/&amp;/sg;
     $s =~ s/</&lt;/sg;
     $s =~ s/>/&gt;/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;
 <?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
 }
 #   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</$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 "" 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}}) .
             "</$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
 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  <rdf:bag>\n" .
                 join("",
                      map {
                          ref $_
                          ? "$i    <resource".
                            ( exists $_->{attrname}
                              ? " $_->{attrname}=\"".e($_->{attrval})."\""
                              : ""
                            ) .
                            ">".e($_->{resource})."</resource>\n"
                          : "$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, $S, $T, $D) = @_;
     print $fh "    <Repository rdf:resource=\"$res\" href=\"$href\"";
     if ($opt_S && defined($S) && $S ne "") {
         print $fh " size=\"$S\"";
     }
     if ($opt_T && defined($T) && $T ne "") {
         print $fh " mtime=\"$T\"";
     }
     if ($opt_D && defined($D) && $D ne "") {
         print $fh " md5=\"$D\"";
     }
     print $fh "/>\n";
 }
 #   send out reference to other resources
 sub xml_other ($$$$$$) {
     my($fh, $about, $href, $S, $T, $D) = @_;
     print $fh "    <rdf:Description about=\"$about\" href=\"$href\"";
     if ($opt_S && defined($S) && $S ne "") {
         print $fh " size=\"$S\"";
     }
     if ($opt_T && defined($T) && $T ne "") {
         print $fh " mtime=\"$T\"";
     }
     if ($opt_D && defined($D) && $D ne "") {
         print $fh " md5=\"$D\"";
     }
     print $fh ">\n";
     print $fh "    </rdf:Description>\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 "    <rdf:Description about=\"$about\" href=\"$href\"";
     if ($opt_S && defined($S) && $S ne "") {
         print $fh " size=\"$S\"";
     }
     if ($opt_T && defined($T) && $T ne "") {
         print $fh " mtime=\"$T\"";
     }
     if ($opt_D && defined($D) && $D ne "") {
         print $fh " md5=\"$D\"";
     }
     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 "    </rdf:Description>\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 = <<EOFEOF;
 Name %{Name}
 Version %{Version}
 Release %{Release}
 URL %{URL}
 Summary %{Summary}
 Copyright %{Copyright}
 License %{License}
 Distribution %{Distribution}
 Vendor %{Vendor}
 Class %{Class}
 Group %{Group}
 Packager %{Packager}
 Prefixes %{Prefixes}
 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
     open(PIPE, "$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 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 = <FH>; }
     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 =~ /<Repository.*?rdf:resource="([^"]+)"/) {
         return $1;
     }
     return undef;
 }
 #############################################################################
 ##
 ##  OpenPKG XML/RDF Index Output Generation
 ##
 #############################################################################
 sub sizetime ($) {
     my ($file) = @_;
     my @stat = stat($file);
     return ($stat[7], $stat[9]);
 }
 sub digest ($) {
     my ($file) = @_;
     my $digest = "";
     my $output = `($OPENSSL md5 -hex "$file") 2>/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 $_";
         }
     }
 }

OpenPKG Specs / annotate

openpkg/index.pl@a2c6460cfb16 (annotated)

openpkg/index.pl