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

openpkg/index.pl@c10fb90893b9 (annotated)

openpkg/index.pl

Thu, 04 Oct 2012 20:30:05 +0200

author: Michael Schloh von Bennewitz <michael@schloh.com>
date: Thu, 04 Oct 2012 20:30:05 +0200
changeset 715: c10fb90893b9
permissions: -rw-r--r--

Correct out of date build configuration, porting to Solaris 11 network
link infrastructure and new libpcap logic. This additionally allows for
device drivers in subdirectories of /dev. Correct packaged nmap
personalities and signatures to work out of the box. Finally, hack
arpd logic to properly close sockets and quit on TERM by repeating
signaling in the run command script. Sadly, all this fails to correct
the run time behaviour of honeyd which fails to bind to the IP layer.

 ##
 ##  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@c10fb90893b9 (annotated)

openpkg/index.pl