michael@428: ##
michael@428: ##  index.pl -- OpenPKG Maintenance Tool (backend for indexing)
michael@428: ##  Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/>
michael@428: ##
michael@428: ##  This software is property of the OpenPKG GmbH, DE MUC HRB 160208.
michael@428: ##  All rights reserved. Licenses which grant limited permission to use,
michael@428: ##  copy, modify and distribute this software are available from the
michael@428: ##  OpenPKG GmbH.
michael@428: ##
michael@428: ##  THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED
michael@428: ##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
michael@428: ##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
michael@428: ##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
michael@428: ##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
michael@428: ##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
michael@428: ##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
michael@428: ##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
michael@428: ##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
michael@428: ##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
michael@428: ##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
michael@428: ##  SUCH DAMAGE.
michael@428: ##
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  MAIN PROCEDURE
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: require 5;
michael@428: #use strict;
michael@428: 
michael@428: #   determine OpenPKG instance prefix via
michael@428: #   1. the environment of the "openpkg build" framework
michael@428: #   2. the installation path of the script
michael@428: #   3. the installation path of the Perl interpreter
michael@428: #   4. the path of the "openpkg" command in $PATH
michael@428: my $l_prefix = $ENV{'OPENPKG_PREFIX'};
michael@428: if (not $l_prefix) {
michael@428:     ($l_prefix) = ($0 =~ m/^(.+)\/lib(exec)?\/openpkg(-tools)?\/build(\.pl)?$/);
michael@428: }
michael@428: if (not $l_prefix) {
michael@428:     ($l_prefix) = ($^X =~ m/^(.+)\/bin\/perl.*$/);
michael@428: }
michael@428: if (not $l_prefix) {
michael@428:     $l_prefix = (`(which openpkg) 2>/dev/null` =~ m/^(.+)\/bin\/openpkg$/);
michael@428: }
michael@428: if (not -x "$l_prefix/bin/openpkg") {
michael@428:     die "openpkg:index:FATAL: cannot determine OpenPKG instance prefix";
michael@428: }
michael@428: 
michael@428: #   determine tools
michael@428: my $RPM = ((-f "$l_prefix/bin/openpkg" && -f "$l_prefix/libexec/openpkg/rpm") ?
michael@428:           "$l_prefix/bin/openpkg rpm" : "$l_prefix/bin/rpm");
michael@428: my $R2C = ((-f "$l_prefix/bin/openpkg" && -f "$l_prefix/libexec/openpkg/rpm2cpio") ?
michael@428:           "$l_prefix/bin/openpkg rpm2cpio" : "$l_prefix/bin/rpm2cpio");
michael@428: my $BZ  = "$l_prefix/lib/openpkg/bzip2 -9";
michael@428: my $OPENSSL = "$l_prefix/lib/openpkg/openssl";
michael@428: 
michael@428: #   parse command line
michael@428: our ($opt_r, $opt_p, $opt_S, $opt_T, $opt_D, $opt_C, $opt_o, $opt_c, $opt_i);
michael@428: my $getopts = 'r:p:STDC:o:ci';
michael@428: getopts($getopts);
michael@428: if ($#ARGV < 0) {
michael@428:     print "openpkg:index:USAGE: openpkg index [-r resource] [-p platform] [-S] [-T] [-D] [-C cache.db] [-o index.rdf] [-c] [-i] dir ...\n";
michael@428:     exit(1);
michael@428: }
michael@428: 
michael@428: #   optionally open cache file
michael@428: my %cache;
michael@428: if ($opt_C) {
michael@428:     eval {
michael@428:         require DB_File;
michael@428:     };
michael@428:     if ($@) {
michael@428:         die "openpkg:index:FATAL: The -C option requires an installed DB_File perl module.";
michael@428:     }
michael@428:     eval {
michael@428:         require Fcntl;
michael@428:     };
michael@428:     if ($@) {
michael@428:         die "openpkg:index:FATAL: The -C option requires an installed Fcntl perl module.";
michael@428:     }
michael@428:     tie %cache, 'DB_File', $opt_C, Fcntl::O_CREAT()|Fcntl::O_RDWR(), 0666, $DB_File::DB_HASH
michael@428:         or die "openpkg:index:FATAL: cannot tie cache '$opt_C' ($!)";
michael@428: }
michael@428: 
michael@428: #   provide default for repository path
michael@428: $opt_r = 'OpenPKG-CURRENT/Source/' if (not defined($opt_r));
michael@428: 
michael@428: #   create make_resource function closure
michael@428: my $make_resource = gen_make_resource();
michael@428: 
michael@428: #   determine output channel
michael@428: my $fh;
michael@428: my $tmpo;
michael@428: if (defined($opt_o)) {
michael@428:     $tmpo = $opt_o . '.tmp';
michael@428:     if ($opt_c) {
michael@428:         open(FH, "| $BZ -c > '$tmpo'")
michael@428:             or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
michael@428:     } else {
michael@428:         open(FH, "> $tmpo")
michael@428:             or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
michael@428:     }
michael@428: } else {
michael@428:     if ($opt_c) {
michael@428:         open(FH, "| $BZ -c")
michael@428:             or die "openpkg:index:FATAL: cannot write to stdout ($!)";
michael@428:     } else {
michael@428:         open(FH, ">&=1")
michael@428:             or die "openpkg:index:FATAL: cannot write to stdout ($!)";
michael@428:     }
michael@428: }
michael@428: $fh = \*FH;
michael@428: 
michael@428: #   generate XML/RDF output
michael@428: xml_head($fh, $opt_r);
michael@428: foreach my $prefix (@ARGV) {
michael@428:     my $list;
michael@428:     if (-d $prefix) {
michael@428:         if ($opt_i) {
michael@428:             $list = list_rpmdir($prefix);
michael@428:         } else {
michael@428:             $list = list_specdir($prefix);
michael@428:         }
michael@428:     } else {
michael@428:         $list = [ $prefix ];
michael@428:         $prefix = dirname($prefix);
michael@428:     }
michael@428:     write_index($fh, $prefix, $opt_r, $opt_p, $list, $opt_C ? \%cache : undef);
michael@428: }
michael@428: xml_foot($fh);
michael@428: 
michael@428: #   close output channel
michael@428: close($fh)
michael@428:     or die "openpkg:index:FATAL: write error on output ($!)";
michael@428: 
michael@428: #   post-process output
michael@428: if (defined($tmpo)) {
michael@428:     rename($tmpo, $opt_o)
michael@428:         or die "openpkg:index:FATAL: cannot rename $tmpo to $opt_o ($!)";
michael@428: }
michael@428: 
michael@428: #   die gracefully
michael@428: exit(0);
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  FUNCTIONS: PARSING
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   home-brewn getopt(3) style option parser
michael@428: sub getopts ($) {
michael@428:     my ($opts) = @_;
michael@428:     my (%optf) = map { m/(\w)/; $1 => $_ } $opts =~ m/(\w:|\w)/g;
michael@428:     my (%opts, @argv, $optarg);
michael@428: 
michael@428:     foreach (@ARGV) {
michael@428:         if (@argv) {
michael@428:             push @argv, $_;
michael@428:         } elsif (defined $optarg) {
michael@428:             if (exists $opts{$optarg}) {
michael@428:                 $opts{$optarg} .= " $_";
michael@428:             } else {
michael@428:                 $opts{$optarg} = $_;
michael@428:             }
michael@428:             $optarg = undef;
michael@428:         } elsif (!/^[-]/) {
michael@428:             push @argv, $_;
michael@428:         } else {
michael@428:             while (/^\-(\w)(.*)/) {
michael@428:                 if (exists $optf{$1}) {
michael@428:                     if (length($optf{$1}) > 1) {
michael@428:                         if ($2 ne '') {
michael@428:                             if (exists $opts{$1}) {
michael@428:                                 $opts{$1} .= " $2";
michael@428:                             } else {
michael@428:                                 $opts{$1} = $2;
michael@428:                             }
michael@428:                         } else {
michael@428:                             $optarg = $1;
michael@428:                         }
michael@428:                         last;
michael@428:                     } else {
michael@428:                         $opts{$1} = 1;
michael@428:                     }
michael@428:                 } else {
michael@428:                     warn "openpkg:index:WARNING: unknown option $_\n";
michael@428:                 }
michael@428:                 $_ = "-$2";
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     if (defined $optarg) {
michael@428:         warn "openpkg:index:WARNING: option $optarg requires an argument\n";
michael@428:     }
michael@428:     foreach (keys %opts) {
michael@428:         eval '$opt_'.$_.' = "'.quotemeta($opts{$_}).'";';
michael@428:     }
michael@428:     @ARGV = @argv;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  OpenPKG RPM Package Specification Parsing
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   escape XML for output in RDF file
michael@428: sub e ($) {
michael@428:     my ($s) = @_;
michael@428:     my ($i);
michael@428: 
michael@428:     #   remove trailing whitespace
michael@428:     $s =~ s/\n+$//sg;
michael@428:     $s =~ s/[^\S\n]+$//mg;
michael@428: 
michael@428:     #   remove common leading whitespace
michael@428:     $i = undef;
michael@428:     while ($s =~ m/^([^\S\n]+)/mg) {
michael@428:         $i = $1 if (!defined($i) || (length($1) < length($i)));
michael@428:     }
michael@428:     $s =~ s/^\Q$i\E//mg if (defined($i));
michael@428: 
michael@428:     #   escape XML special characters
michael@428:     $s =~ s/&/&amp;/sg;
michael@428:     $s =~ s/</&lt;/sg;
michael@428:     $s =~ s/>/&gt;/sg;
michael@428: 
michael@428:     return $s;
michael@428: }
michael@428: 
michael@428: #   make_resource closure
michael@428: sub gen_make_resource {
michael@428:     #   generate operator regular expression
michael@428:     #   (used in make_resource below)
michael@428:     my %attrname = (
michael@428:         '=='  => 'equ',
michael@428:         '='   => 'equ',
michael@428:         '>='  => 'geq',
michael@428:         '=>'  => 'geq',
michael@428:         '<='  => 'leq',
michael@428:         '=<'  => 'leq',
michael@428:         '>'   => 'gt',
michael@428:         '<'   => 'lt'
michael@428:     );
michael@428:     my ($opreg) =
michael@428:         join '|',
michael@428:         map {
michael@428:             "\Q$_\E"
michael@428:         } sort {
michael@428:                length($b) <=> length($a)
michael@428:             || $b cmp $a
michael@428:         } keys(%attrname);
michael@428: 
michael@428:     #   return function which makes resource object
michael@428:     return sub ($) {
michael@428:         my ($s) = @_;
michael@428: 
michael@428:         if ($s =~ m/(\S+)\s*($opreg)\s*(.*?)\s*$/o) {
michael@428:             return {
michael@428:                 resource  => $1,
michael@428:                 attrname  => $attrname{$2},
michael@428:                 attrval   => $3
michael@428:             }
michael@428:         }
michael@428:         else {
michael@428:             return {
michael@428:                 resource => $s
michael@428:             }
michael@428:         }
michael@428:     };
michael@428: };
michael@428: 
michael@428: #   split string into array at comma seperator
michael@428: #   (optioanlly map resource operators into resource objects)
michael@428: sub commasep ($$) {
michael@428:     my ($k, $v) = @_;
michael@428: 
michael@428:     if ($k =~ m/^(NoSource)$/) {
michael@428:         return split(/\s*,\s*/, $v);
michael@428:     } elsif ($k =~ /^(PreReq|BuildPreReq|Provides|Conflicts)$/) {
michael@428:         return map { &$make_resource($_) }
michael@428:                split(/\s*,\s*/, $v);
michael@428:     }
michael@428:     return $v;
michael@428: }
michael@428: 
michael@428: #   escape option string
michael@428: sub optesc ($) {
michael@428:     my ($s) = @_;
michael@428: 
michael@428:     $s =~ s/([\x00-\x1f\x80-\xbf\s\%])/sprintf("%%%02x", ord($1))/eg;
michael@428:     return $s;
michael@428: }
michael@428: 
michael@428: #   variable substitution
michael@428: sub vsub ($$) {
michael@428:     my ($var, $v) = @_;
michael@428: 
michael@428:     $v =~ s/\%\{([^}]+)\}/
michael@428:         exists $var->{$1} ? $var->{$1} : '%{'.$1.'}'/emg;
michael@428:     return $v;
michael@428: }
michael@428: 
michael@428: #   Umgekehrte Polnische Notation (UPN)
michael@428: #   Reverse Polish Notation (RPN)
michael@428: #   << ( %{foo} == "yes" ) && ( ! %{bar} == "no" ) || ( %{baz} == "yes" )
michael@428: #   >> %{foo} %{bar} ! && %{baz} ||
michael@428: sub upn ($) {
michael@428:     my ($t) = @_;
michael@428:     my (@tok);
michael@428:     my (@out, $op, $o);
michael@428:     my (@save);
michael@428: 
michael@428:     #   split string into tokens
michael@428:     @tok = ($t =~ m/(\(|\)|\&\&|\|\||\!|\S+)/g);
michael@428: 
michael@428:     #   iterate over all tokens
michael@428:     $op = [];
michael@428:     foreach (@tok) {
michael@428:         if ($_ eq '(') {
michael@428:             push(@save, $op);
michael@428:             $op = [];
michael@428:         } elsif ($_ eq ')') {
michael@428:             die "openpkg:index:FATAL: unresolved operators in: @tok\n" if (@$op);
michael@428:             $op = pop(@save)
michael@428:                 or die "openpkg:index:FATAL: unmatched closing parenthesis in: @tok\n";
michael@428:             while ($o = pop(@$op)) {
michael@428:                 push(@out, $o->[0]);
michael@428:                 last if ($o->[1]);
michael@428:             }
michael@428:         } elsif ($_ eq '&&') {
michael@428:             push(@$op, [ '+', 1 ]);
michael@428:         } elsif ($_ eq '||') {
michael@428:             push(@$op, [ '|', 1 ]);
michael@428:         } elsif ($_ eq '!') {
michael@428:             push(@$op, [ '!', 0 ]);
michael@428:         } elsif (m/^\%\{(\S*?)\}$/) {
michael@428:             push(@out, $1);
michael@428:             while ($o = pop(@$op)) {
michael@428:                 push(@out, $o->[0]);
michael@428:                 last if ($o->[1]); # binary operator
michael@428:             }
michael@428:         }
michael@428:     }
michael@428:     return join (' ', @out);
michael@428: }
michael@428: 
michael@428: #   deduce external variables from description
michael@428: #   (backward compatibility for times before openpkg-20021230)
michael@428: sub find_options ($) {
michael@428:     my ($descr) = @_;
michael@428:     my $evar = {};
michael@428:     $descr =~ s/--define\s*'(\S+)\s*\%\{\1\}'/$evar->{$1} = '%{'.$1.'}', ''/sge;
michael@428:     return $evar;
michael@428: }
michael@428: 
michael@428: #   translate default section from spec-file into a hash
michael@428: #   - %if/%ifdef/%define... are translated to #/#ifdef/#define
michael@428: #   - #defines are interpolated (correct ?)
michael@428: #   - #if/#ifdef/... sections are stripped
michael@428: #     result is the same as if all conditions evaluate false (!)
michael@428: #   - all attributes are of the form key: value
michael@428: #   - repeated attributes are coalesced into a list
michael@428: #   hint: evar = expansion variables, ovar = option variables
michael@428: sub package2data ($$) {
michael@428:     my ($s, $ovar) = @_;
michael@428:     my (%evar, %var);
michael@428:     my (@term, $term);
michael@428:     my (%attr, %avar);
michael@428:     my ($l, $v, $cond, $d, $p);
michael@428:     my ($re, @defs);
michael@428: 
michael@428:     #   combine multilines (line continuation!)
michael@428:     $s =~ s/\\\n/ /sg;
michael@428: 
michael@428:     #   map syntax of conditional variable macros
michael@428:     $s =~ s/^#\{\!\?([^:]*):\s*%(.*?)\s*\}\s*$/#ifndef $1\n#$2\n#endif/mg;
michael@428:     $s =~ s/^#\{\!\?([^:]*):\s*(.*?)\s*\}\s*$/#ifndef $1\n$2\n#endif/mg;
michael@428: 
michael@428:     #   map syntax of option macro
michael@428:     $s =~ s/^#option\s+(\S+)\s*(.*?)\s*$/#ifndef $1\n#define $1 $2\n#endif\n#provides $1 $2/mg;
michael@428: 
michael@428:     #   use option variables for expansion
michael@428:     %evar = %$ovar;
michael@428: 
michael@428:     #   guess more external parameters by scanning for (and removing) "set option default" sections
michael@428:     $re = '^\#ifndef\s+[\w\_]+\s*\n((?:\#define\s+[\w\_]+\s.*\n)+)\#endif\n';
michael@428:     @defs = ($s =~ m/$re/gm);
michael@428:     foreach (@defs) {
michael@428:         while (m/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
michael@428:             $ovar->{$1} = $2;
michael@428:             $evar{$1} = '%{'.$1.'}';
michael@428:         }
michael@428:     }
michael@428:     $s =~ s/$re//gm;
michael@428: 
michael@428:     #   add everything looking like a "with_xxx" variable
michael@428:     $re = '%{(with\_[\w\_]+)}';
michael@428:     @defs = ($s =~ /$re/gm);
michael@428:     foreach (@defs) {
michael@428:         next if (exists($ovar->{$1}));
michael@428:         $ovar->{$1} = '%{'.$1.'}'; # unexpanded
michael@428:         $evar{$1} = '%{'.$1.'}';
michael@428:     }
michael@428: 
michael@428:     #   extract all conditional sections (#if/#else/#endif)
michael@428:     @term = ();
michael@428:     %var  = ();
michael@428:     $cond = '';
michael@428:     foreach $l (split(/\n/, $s)) {
michael@428:         #   expand variables
michael@428:         $v = vsub(\%avar, vsub(\%var, $l));
michael@428: 
michael@428:         if (($p) = ($v =~ /^\#if\s+(.*?)\s*$/)) {
michael@428:             #   normalize "%{variable}" != ..."
michael@428:             $p =~ s/("\%\{[^}]+\}")\s*!=\s*"(yes|no)"/$1 . " == \"" . ($2 ne "yes" ? "yes" : "no") . "\""/sge;
michael@428: 
michael@428:             #   normalize #if expressions
michael@428:             #   - "%{variable}" == "yes"
michael@428:             #   - "%{variable}" == "no"
michael@428:             #   - operators ! && ||
michael@428:             #   warn on:
michael@428:             #   - operator !=
michael@428:             #   - any other word
michael@428:             $term = '';
michael@428:             while ($p =~ m/(!=)|(\!|\|\||\&\&|\(|\))|"\%\{([^}]+)\}"\s*==\s*"(yes|no)"|(\S+)/g) {
michael@428:                 if (defined($1)) {
michael@428:                     warn "openpkg:index:WARNING: unknown token '$1':\n< $l\n> $v";
michael@428:                 } elsif (defined($5)) {
michael@428:                     warn "openpkg:index:WARNING: unknown token '$5':\n< $l\n> $v";
michael@428:                 } elsif (defined($2)) {
michael@428:                     $term .= " $2 ";
michael@428:                 } elsif (exists($evar{$3})) {
michael@428:                     $term .= ($4 eq 'no' ? '! ' : '').vsub(\%evar, '%{'.$3.'}');
michael@428:                 } else {
michael@428:                     warn "openpkg:index:WARNING: unknown condition variable '$3':\n< $l\n> $v";
michael@428:                 }
michael@428:             }
michael@428: 
michael@428:             #   join with previous conditions for this #if/#endif block
michael@428:             if ($term ne '') {
michael@428:                 push(@term, "( $term )");
michael@428:                 $cond = join(' && ', grep { $_ ne '' } @term) . '';
michael@428:             } else {
michael@428:                 push(@term, '');
michael@428:             }
michael@428:         }
michael@428:         elsif ($v =~ /^\#else\s*$/) {
michael@428:             #   reverse last condition
michael@428:             if (@term) {
michael@428:                 $term[-1] = ' ! '. $term[-1];
michael@428:                 $cond = join(' && ', grep { $_ ne '' } @term) . '';
michael@428:             } else {
michael@428:                 die "openpkg:index:FATAL: \"else\" without \"if\"";
michael@428:             }
michael@428:         }
michael@428:         elsif ($v =~ /^\#endif\s*$/) {
michael@428:             #   unwind last #if expression
michael@428:             pop(@term);
michael@428:             $cond = join(' && ', grep { $_ ne '' } @term) . '';
michael@428:         }
michael@428:         elsif ($v =~ /^\#(?:define)\s*(\S+)\s*(.*?)\s*$/) {
michael@428:             #   define conditional variables
michael@428:             #   - truth-value becomes current condition
michael@428:             #   define internal variables
michael@428:             #   - store for subsequent substitution
michael@428:             if (exists($evar{$1})) {
michael@428:                 if ($2 eq 'yes') {
michael@428:                     if ($cond eq '') {
michael@428:                         $evar{$1} = "( \%\{$1\} )";
michael@428:                     } else {
michael@428:                         $evar{$1} = "( \%\{$1\} || ( $cond ) )";
michael@428:                     }
michael@428:                 } elsif ($2 eq 'no') {
michael@428:                     if ($cond eq '') {
michael@428:                         $evar{$1} = "( \%\{$1\} )";
michael@428:                     } else {
michael@428:                         $evar{$1} = "( %\{$1\} && ! ( $cond ) )";
michael@428:                     }
michael@428:                 } else {
michael@428:                     warn "openpkg:index:WARNING: logic too complex for '$1' (boolean expressions allowed only):\n< $l\n> $v";
michael@428:                 }
michael@428:             } else {
michael@428:                 $var{$1} = $2;
michael@428:             }
michael@428:         }
michael@428:         elsif ($v =~ /^\#(?:undefine)\s*(\S+)\s*$/) {
michael@428:             #   undefine conditional variables
michael@428:             #   undefine internal variables
michael@428:             if (exists($evar{$1})) {
michael@428:                 $evar{$1} = "\%\{$1\}";
michael@428:             } else {
michael@428:                 delete($var{$1});
michael@428:             }
michael@428:         }
michael@428:         elsif ($v =~ /^\#(?:provides)\s*(\S+)\s*(.*?)\s*$/) {
michael@428:             #   store option for current condition
michael@428:             if (exists($attr{'Name'}->{''})) {
michael@428:                 push(@{$attr{'Provides'}->{$cond}}, {
michael@428:                     resource => $attr{'Name'}->{''}->[0] . '::' . $1,
michael@428:                     attrname => 'equ',
michael@428:                     attrval  => optesc($2)
michael@428:                 });
michael@428:             } else {
michael@428:                 warn "openpkg:index:ERROR: no package name set for option \"$1 = $2\"";
michael@428:             }
michael@428:         }
michael@428:         elsif ($v =~ /^\#NoSource\s*(.*?)\s*$/) {
michael@428:             #   store conditional NoSource attribute
michael@428:             push(@{$attr{'NoSource'}->{$cond}}, commasep('NoSource', $1));
michael@428: 
michael@428:         }
michael@428:         elsif ($v =~ /^\s*([^\#]\S*)\s*:\s*(.*?)\s*$/) {
michael@428:             #   store "attribute: value" headers for current condition
michael@428:             push(@{$attr{$1}->{$cond}}, commasep($1,$2));
michael@428:             $avar{lc($1)} = $2 if ($cond eq '');
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   return all header "attributes"
michael@428:     return \%attr;
michael@428: }
michael@428: 
michael@428: #   split spec file into sections starting with a %word
michael@428: #   - concatenate extended lines
michael@428: #   - strip comment lines
michael@428: #   - map %command to #command
michael@428: #   - split sections
michael@428: #   - return package2data() from default section (before first %xxx section)
michael@428: sub spec2data ($) {
michael@428:     my ($s) = @_;
michael@428:     my (%map);
michael@428:     my ($a, $o);
michael@428:     my $spec = $s;
michael@428: 
michael@428:     #   remove comments
michael@428:     $s =~ s/^\s*#.*?\n//mg;
michael@428: 
michael@428:     #   map commands
michael@428:     $s =~ s/^%(ifdef|ifndef|if|NoSource|option|undefine|define|else|endif|\{)/#$1/mg;
michael@428: 
michael@428:     #   split sections
michael@428:     foreach (split(m/^(?=%\w+\s*\n)/m, $s)) {
michael@428:         if (m/^%(\w+)\s*\n/) {
michael@428:             $map{$1} .= $';
michael@428:         } else {
michael@428:             $map{'*'} .= $_;
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     #   translate package information into "data"
michael@428:     if (exists($map{'description'})) {
michael@428:         #   backward compatibility (options are in description)
michael@428:         $o = find_options($map{'description'});
michael@428:         $a = package2data($map{'*'}, $o );
michael@428:         $a->{'Description'} = { '' => [ $map{'description'} ] };
michael@428:     } else {
michael@428:         #   standard case
michael@428:         $a = package2data($map{'*'}, {});
michael@428:     }
michael@428:     return $a;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  XML/RDF Generation
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   start of XML file
michael@428: sub xml_head ($$) {
michael@428:     my ($fh, $res) = @_;
michael@428:     print $fh <<EOFEOF;
michael@428: <?xml version="1.0" encoding="iso-8859-1"?>
michael@428: <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
michael@428:          xmlns="http://www.openpkg.org/xml-rdf-index/0.9">
michael@428:   <Repository rdf:resource="$res">
michael@428: EOFEOF
michael@428: }
michael@428: 
michael@428: #   end of XML file, corresponds with start tags
michael@428: sub xml_foot ($) {
michael@428:     my($fh) = @_;
michael@428:     print $fh <<EOFEOF;
michael@428:   </Repository>
michael@428: </rdf:RDF>
michael@428: EOFEOF
michael@428: }
michael@428: 
michael@428: #   conditional expansion of attribute
michael@428: sub n ($$) {
michael@428:     my ($a, $k) = @_;
michael@428:     return if (not $a->{$k});
michael@428:     return if (not $a->{$k}->{''});
michael@428:     return ($a->{$k}->{''}->[0]);
michael@428: }
michael@428: 
michael@428: #   send out $a->{$k} as text-style tag
michael@428: sub xml_text ($$$;$) {
michael@428:     my ($i, $a, $k, $tag) = @_;
michael@428:     my ($out);
michael@428:     return "" if (not exists($a->{$k}));
michael@428:     $tag = $k if (not defined($tag));
michael@428:     $i = ' ' x $i;
michael@428:     $out = e(n($a, $k));
michael@428:     return if $out eq '';
michael@428:     return "$i<$tag>\n$out\n$i</$tag>\n";
michael@428: }
michael@428: 
michael@428: #   send out @{$a->{$k}} as body of an XML tag
michael@428: #   $k is the name of the tag unless overridden by $tag
michael@428: #   $i denotes the depth of indentation to form nicely
michael@428: #   looking files.
michael@428: #   all data from the list is flattened into a single
michael@428: #   body, separated by LF and escaped for XML metachars.
michael@428: sub xml_tag ($$$;$) {
michael@428:     my ($i, $a, $k, $tag) = @_;
michael@428:     my ($out, $cond, $upn);
michael@428:     return "" if (not exists($a->{$k}));
michael@428:     $tag = $k if (not defined($tag));
michael@428:     $out = '';
michael@428:     $i = ' ' x $i;
michael@428:     foreach $cond (sort keys(%{$a->{$k}})) {
michael@428:         $upn = e(upn($cond));
michael@428:         $out .= $i .
michael@428:             ($cond ne '' ? "<$tag cond=\"$upn\">" : "<$tag>") .
michael@428:             join("\n", map { e($_) } @{$a->{$k}->{$cond}}) .
michael@428:             "</$tag>\n";
michael@428:     }
michael@428:     return $out;
michael@428: }
michael@428: 
michael@428: #   send out @{$a->{$k}} as a rdf:bag
michael@428: #   $k is the name of the outer tag unless overriden by $tag
michael@428: #   $i denotes the depth of indentation, inner tags are indented
michael@428: #   2 or 4 more character positions.
michael@428: #   each element of the bag is listed
michael@428: sub xml_bag ($$$;$) {
michael@428:     my ($i, $a, $k, $tag) = @_;
michael@428:     my ($out, $cond, $upn);
michael@428:     return "" if (not exists($a->{$k}));
michael@428:     $tag = $k if (not defined($tag));
michael@428:     $out = '';
michael@428:     $i = ' ' x $i;
michael@428:     foreach $cond (sort keys %{$a->{$k}}) {
michael@428:         next if (not @{$a->{$k}->{$cond}});
michael@428:         $upn = e(upn($cond));
michael@428:         $out .= $i .
michael@428:                 ($cond ne '' ? "<$tag cond=\"$upn\">\n" : "<$tag>\n") .
michael@428:                 "$i  <rdf:bag>\n" .
michael@428:                 join("",
michael@428:                      map {
michael@428:                          ref $_
michael@428:                          ? "$i    <resource".
michael@428:                            ( exists $_->{attrname}
michael@428:                              ? " $_->{attrname}=\"".e($_->{attrval})."\""
michael@428:                              : ""
michael@428:                            ) .
michael@428:                            ">".e($_->{resource})."</resource>\n"
michael@428:                          : "$i    <rdf:li>".e($_)."</rdf:li>\n"
michael@428:                      }
michael@428:                      @{$a->{$k}->{$cond}}) .
michael@428:                 "$i  </rdf:bag>\n" .
michael@428:                 "$i</$tag>\n";
michael@428:     }
michael@428:     return $out;
michael@428: }
michael@428: 
michael@428: #   send out reference to another RDF
michael@428: sub xml_reference ($$$$$$) {
michael@428:     my($fh, $res, $href, $S, $T, $D) = @_;
michael@428:     print $fh "    <Repository rdf:resource=\"$res\" href=\"$href\"";
michael@428:     if ($opt_S && defined($S) && $S ne "") {
michael@428:         print $fh " size=\"$S\"";
michael@428:     }
michael@428:     if ($opt_T && defined($T) && $T ne "") {
michael@428:         print $fh " mtime=\"$T\"";
michael@428:     }
michael@428:     if ($opt_D && defined($D) && $D ne "") {
michael@428:         print $fh " md5=\"$D\"";
michael@428:     }
michael@428:     print $fh "/>\n";
michael@428: }
michael@428: 
michael@428: #   send out reference to other resources
michael@428: sub xml_other ($$$$$$) {
michael@428:     my($fh, $about, $href, $S, $T, $D) = @_;
michael@428:     print $fh "    <rdf:Description about=\"$about\" href=\"$href\"";
michael@428:     if ($opt_S && defined($S) && $S ne "") {
michael@428:         print $fh " size=\"$S\"";
michael@428:     }
michael@428:     if ($opt_T && defined($T) && $T ne "") {
michael@428:         print $fh " mtime=\"$T\"";
michael@428:     }
michael@428:     if ($opt_D && defined($D) && $D ne "") {
michael@428:         print $fh " md5=\"$D\"";
michael@428:     }
michael@428:     print $fh ">\n";
michael@428:     print $fh "    </rdf:Description>\n";
michael@428: }
michael@428: 
michael@428: #   translate attributes from %$a as generated by package2data
michael@428: #   into XML and write to file $fh
michael@428: sub xml_record ($$$$$$) {
michael@428:     my ($fh, $a, $href, $S, $T, $D) = @_;
michael@428:     my ($maj, $min, $rel, $about);
michael@428: 
michael@428:     $about =
michael@428:         n($a, 'Name') . '-' .
michael@428:         n($a, 'Version') . '-' .
michael@428:         n($a, 'Release');
michael@428:     if (not defined($href)) {
michael@428:         #   guess location from Information in Specfile
michael@428:         if (exists($a->{'NoSource'})) {
michael@428:             $href = "$about.nosrc.rpm";
michael@428:         } else {
michael@428:             $href = "$about.src.rpm";
michael@428:         }
michael@428:         ($maj, $min, $rel) = (n($a, 'Release') =~ m/^(\d+)\.(\d+)\.(\d+)/);
michael@428:         if (defined($min)) {
michael@428:             if ($maj > 1 || ($maj == 1 && $min > 0)) {
michael@428:                 #   OpenPKG-1.1-RELEASE or later
michael@428:                 if (n($a, 'Distribution') =~ /\[PLUS\]/) {
michael@428:                     $href = 'PLUS/'.$href;
michael@428:                 }
michael@428:             }
michael@428:             if ($maj > 1 || ($maj == 1 && $min >= 0)) {
michael@428:                 #   OpenPKG-1.0-RELEASE or later
michael@428:                 if ($rel > 0) {
michael@428:                     $href = 'UPD/'.$href;
michael@428:                 }
michael@428:             }
michael@428:         } else {
michael@428:             #   OpenPKG-CURRENT
michael@428:         }
michael@428:     }
michael@428: 
michael@428:     print $fh "    <rdf:Description about=\"$about\" href=\"$href\"";
michael@428:     if ($opt_S && defined($S) && $S ne "") {
michael@428:         print $fh " size=\"$S\"";
michael@428:     }
michael@428:     if ($opt_T && defined($T) && $T ne "") {
michael@428:         print $fh " mtime=\"$T\"";
michael@428:     }
michael@428:     if ($opt_D && defined($D) && $D ne "") {
michael@428:         print $fh " md5=\"$D\"";
michael@428:     }
michael@428:     print $fh ">\n";
michael@428: 
michael@428:     #   fake Source attribute from Source\d attribtutes
michael@428:     #   XXX only default conditional
michael@428:     $a->{'Source'} = { '' => [
michael@428:         map {
michael@428:             s/\Q%{name}\E/n($a, 'Name')/esg;
michael@428:             s/\Q%{version}\E/n($a, 'Version')/esg;
michael@428:             s/\Q%{release}\E/n($a, 'Release')/esg;
michael@428:             $_;
michael@428:         }
michael@428:         map {
michael@428:             $a->{$_}->{''} ? @{$a->{$_}->{''}} : ()
michael@428:         }
michael@428:         sort {
michael@428:             my ($x) = ($a =~ /^(\d*)$/);
michael@428:             my ($y) = ($b =~ /^(\d*)$/);
michael@428:             return $x <=> $y;
michael@428:         }
michael@428:         grep {
michael@428:             /^Source\d*$/
michael@428:         } keys(%$a)
michael@428:     ]};
michael@428:     delete($a->{'Source'}) if (not @{$a->{'Source'}->{''}});
michael@428: 
michael@428:     print $fh
michael@428:         xml_tag(6,  $a, 'Name'),
michael@428:         xml_tag(6,  $a, 'Version'),
michael@428:         xml_tag(6,  $a, 'Release'),
michael@428:         xml_tag(6,  $a, 'Distribution'),
michael@428:         xml_tag(6,  $a, 'Class'),
michael@428:         xml_tag(6,  $a, 'Group'),
michael@428:         xml_tag(6,  $a, 'License'),
michael@428:         xml_tag(6,  $a, 'Packager'),
michael@428:         xml_tag(6,  $a, 'Summary'),
michael@428:         xml_tag(6,  $a, 'URL'),
michael@428:         xml_tag(6,  $a, 'Vendor'),
michael@428:         xml_tag(6,  $a, 'SourceRPM'),
michael@428:         xml_tag(6,  $a, 'Arch'),
michael@428:         xml_tag(6,  $a, 'Os'),
michael@428:         xml_tag(6,  $a, 'BuildHost'),
michael@428:         xml_tag(6,  $a, 'BuildSystem'),
michael@428:         xml_tag(6,  $a, 'BuildTime'),
michael@428:         xml_tag(6,  $a, 'Relocations'),
michael@428:         xml_tag(6,  $a, 'Size'),
michael@428:         xml_tag(6,  $a, 'Prefixes'),
michael@428:         xml_tag(6,  $a, 'Platform'),
michael@428:         xml_tag(6,  $a, 'SigSize'),
michael@428:         xml_tag(6,  $a, 'SigMD5'),
michael@428:         xml_tag(6,  $a, 'SigPGP'),
michael@428:         xml_tag(6,  $a, 'SigGPG'),
michael@428:         xml_bag(6,  $a, 'BuildPreReq'),
michael@428:         xml_bag(6,  $a, 'PreReq'),
michael@428:         xml_bag(6,  $a, 'Provides'),
michael@428:         xml_bag(6,  $a, 'Conflicts'),
michael@428:         xml_bag(6,  $a, 'Source'),
michael@428:         xml_bag(6,  $a, 'NoSource'),
michael@428:         xml_bag(6,  $a, 'Filenames'),
michael@428:         xml_text(6, $a, 'Description');
michael@428: 
michael@428:     print $fh "    </rdf:Description>\n";
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  OpenPKG RPM Package Payload Extraction
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   extract foo.spec from foo-V-R.src.rpm file
michael@428: sub rpm2spec ($) {
michael@428:     my ($fn) = @_;
michael@428:     local($SIG{'PIPE'}) = 'IGNORE';
michael@428:     local(*PIPE);
michael@428:     open(PIPE, "$R2C '$fn' |")
michael@428:         or die "openpkg:index:FATAL: cannot read '$fn' ($!)\n";
michael@428:     my ($buf, @hdr, $n, $m, $name, $step);
michael@428:     my ($spec);
michael@428:     while (read(PIPE, $buf, 110) == 110) {
michael@428:         @hdr = unpack('a6a8a8a8a8a8a8a8a8a8a8a8a8a8', $buf);
michael@428:         $n = hex($hdr[12]);      # filename length
michael@428:         $m = int(($n+5)/4)*4-2;  # filename size (padded)
michael@428:         last if (not (read(PIPE,$buf,$m) == $m));
michael@428:         $name = substr($buf, 0, $n-1);
michael@428:         $n = hex($hdr[7]);       # file length
michael@428:         $m = int(($n+3)/4)*4;    # file size (padded)
michael@428:         if ($name !~ m/.spec$/) {
michael@428:             while ($m > 0) {
michael@428:                 $step = $m > 8192 ? 8192 : $m;
michael@428:                 last if (not read(PIPE,$buf,$step));
michael@428:                 $m -= length($buf);
michael@428:             }
michael@428:         } else {
michael@428:             if (read(PIPE,$buf,$n) == $n) {
michael@428:                 $spec = $buf;
michael@428:             }
michael@428:             last;
michael@428:         }
michael@428:     }
michael@428:     close(PIPE);
michael@428:     return $spec;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  OpenPKG RPM Package Header Extraction
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   extract header information from foo-V-R.src.rpm
michael@428: sub rpm2data ($$) {
michael@428:     my ($fn, $platform) = @_;
michael@428:     my ($q, %a);
michael@428:     my ($t, $v);
michael@428:     local(*PIPE);
michael@428: 
michael@428:     if (not defined($platform)) {
michael@428:         die "openpkg:index:FATAL: indexing binary package '$fn' requires -p option\n";
michael@428:     }
michael@428: 
michael@428:     $q = <<EOFEOF;
michael@428: Name %{Name}
michael@428: Version %{Version}
michael@428: Release %{Release}
michael@428: URL %{URL}
michael@428: Summary %{Summary}
michael@428: Copyright %{Copyright}
michael@428: License %{License}
michael@428: Distribution %{Distribution}
michael@428: Vendor %{Vendor}
michael@428: Class %{Class}
michael@428: Group %{Group}
michael@428: Packager %{Packager}
michael@428: Prefixes %{Prefixes}
michael@428: BuildHost %{BuildHost}
michael@428: BuildTime %{BuildTime}
michael@428: Arch %{Arch}
michael@428: Os %{Os}
michael@428: Size %{Size}
michael@428: SigSize %{SigSize}
michael@428: SigMD5 %{SigMD5}
michael@428: SigPGP %{SigPGP}
michael@428: SigGPG %{SigGPG}
michael@428: SourceRPM %{SourceRPM}
michael@428: [Patch %{Patch}
michael@428: ]
michael@428: [Source %{Source}
michael@428: ]
michael@428: [Filenames %{Filenames}
michael@428: ]
michael@428: [Conflicts %{CONFLICTNAME} %|CONFLICTFLAGS?{%{CONFLICTFLAGS:depflags} %{CONFLICTVERSION}}:{}|
michael@428: ]
michael@428: [PreReq %{REQUIRENAME} %|REQUIREFLAGS?{%{REQUIREFLAGS:depflags} %{REQUIREVERSION}}:{}|
michael@428: ]
michael@428: [Provides %{PROVIDENAME} %|PROVIDEFLAGS?{%{PROVIDEFLAGS:depflags} %{PROVIDEVERSION}}:{}|
michael@428: ]
michael@428: Description %{Description}
michael@428: EOFEOF
michael@428: 
michael@428:     open(PIPE, "$RPM -qp --qf '$q' '$fn' |")
michael@428:         or die "FATAL: cannot read '$fn' ($!)\n";
michael@428:     while (<PIPE>) {
michael@428:         if (/^(\S+)\s+(.*?)\s*$/) {
michael@428:             $t = $1;
michael@428:             $v = $2;
michael@428:         } elsif (/^(\s+.+?)\s*$/) {
michael@428:             next if (not defined($t));
michael@428:             $v = $1;
michael@428:         } else {
michael@428:             $t = undef;
michael@428:             next;
michael@428:         }
michael@428:         if (exists($a{$t})) {
michael@428:             $a{$t} .= "\n$v";
michael@428:         } else {
michael@428:             $a{$t} = $v;
michael@428:         }
michael@428:     }
michael@428:     close(PIPE);
michael@428: 
michael@428:     %a = map { $_ => $a{$_} }
michael@428:          grep { $a{$_} ne '(none)' }
michael@428:          keys(%a);
michael@428:     if ($a{'Relocations'} eq '(non relocatable)') {
michael@428:         delete($a{'Relocations'});
michael@428:     }
michael@428:     if ($a{'SigMD5'} eq '(unknown type)') {
michael@428:         delete($a{'SigMD5'});
michael@428:     }
michael@428:     if (defined($platform)) {
michael@428:         $a{'Platform'} = $platform;
michael@428:     }
michael@428:     $a{'Description'} = [ $a{'Description'} ];
michael@428: 
michael@428:     foreach ('Conflicts', 'PreReq', 'Provides') {
michael@428:         $a{$_} = [
michael@428:             map { &$make_resource($_) }
michael@428:             grep { !/^rpmlib\(/ }
michael@428:             split(/\n+/, $a{$_})
michael@428:         ];
michael@428:     }
michael@428: 
michael@428:     return { map {
michael@428:         $_ => { '' => (ref $a{$_} ? $a{$_} : [ split(/\n+/, $a{$_}) ]) }
michael@428:     } keys(%a) };
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  OpenPKG XML/RDF Index Locating
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   detect index files
michael@428: sub getindex ($) {
michael@428:     my ($dir) = @_;
michael@428:     my (@idx) =
michael@428:         sort { -M $a <=> -M $b; }
michael@428:         grep { -f $_ }
michael@428:         ( <$dir/00INDEX.rdf>, <$dir/00INDEX.rdf.*> );
michael@428:     return if (not @idx);
michael@428:     return $idx[0];
michael@428: }
michael@428: 
michael@428: #   list RPM directories of unpacked .spec files
michael@428: sub list_specdir ($) {
michael@428:     my ($dir) = @_;
michael@428:     my ($d, $path);
michael@428:     my (@list);
michael@428: 
michael@428:     local(*DH);
michael@428:     opendir(DH, $dir);
michael@428:     while ($d = readdir(DH)) {
michael@428:         next if ($d =~ m/^\./);
michael@428:         $path = "$dir/$d/$d.spec";
michael@428:         push(@list, $path) if (-f $path);
michael@428:     }
michael@428:     closedir(DH);
michael@428:     return \@list;
michael@428: }
michael@428: 
michael@428: #   list index or RPM file directories
michael@428: sub list_rpmdir ($) {
michael@428:     my ($dir) = @_;
michael@428:     my ($d, $path);
michael@428:     my (@list, $idx, $sub);
michael@428: 
michael@428:     local(*DH);
michael@428:     opendir(DH, $dir);
michael@428:     while ($d = readdir(DH)) {
michael@428:         next if ($d =~ m/^\./);
michael@428:         $path = "$dir/$d";
michael@428:         if (-d $path) {
michael@428:             $idx = getindex($path);
michael@428:             if (defined($idx)) {
michael@428:                 push(@list, $idx);
michael@428:             } else {
michael@428:                 $sub = list_rpmdir($path);
michael@428:                 push(@list, @$sub);
michael@428:                 undef $sub;
michael@428:             }
michael@428:         } else {
michael@428:             next if (not ($d =~ m/\.(?:rpm|sh)$/ && -f $path));
michael@428:             push(@list, $path);
michael@428:         }
michael@428:     }
michael@428:     closedir(DH);
michael@428:     return \@list;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  OpenPKG XML/RDF Index Reading
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: #   fetch a whole file
michael@428: sub readfile ($) {
michael@428:     my ($fn) = @_;
michael@428:     local(*FH);
michael@428:     open(FH, "< $fn")
michael@428:         or die "FATAL: cannot read '$fn' ($!)\n";
michael@428:     my $l; { local $/; $l = <FH>; }
michael@428:     close(FH);
michael@428:     return $l;
michael@428: }
michael@428: 
michael@428: #   create relative path by stripping instance prefix
michael@428: sub relpath ($$) {
michael@428:     my ($prefix, $path) = @_;
michael@428:     $path =~ s/^\Q$prefix\E\///s;
michael@428:     return $path;
michael@428: }
michael@428: 
michael@428: #   create directory path with trailing slash
michael@428: sub dirname ($) {
michael@428:     my ($path) = @_;
michael@428:     $path =~ s/\/[^\/]*$//s;
michael@428:     return $path.'/';
michael@428: }
michael@428: 
michael@428: #   peek at resource identifier of index file
michael@428: sub getresource ($) {
michael@428:     my ($fn) = @_;
michael@428:     my ($fh, $buf);
michael@428: 
michael@428:     local(*FH);
michael@428:     if ($fn =~ /\.bz2$/) {
michael@428:         open(FH, "$BZ -dc $fn |")
michael@428:             or die "FATAL: cannot read '$fn' ($!)\n";
michael@428:     } else {
michael@428:         open(FH, "< $fn")
michael@428:             or die "FATAL: cannot read '$fn' ($!)\n";
michael@428:     }
michael@428:     read(FH, $buf, 1024);
michael@428:     close(FH);
michael@428:     if ($buf =~ /<Repository.*?rdf:resource="([^"]+)"/) {
michael@428:         return $1;
michael@428:     }
michael@428:     return undef;
michael@428: }
michael@428: 
michael@428: #############################################################################
michael@428: ##
michael@428: ##  OpenPKG XML/RDF Index Output Generation
michael@428: ##
michael@428: #############################################################################
michael@428: 
michael@428: sub sizetime ($) {
michael@428:     my ($file) = @_;
michael@428:     my @stat = stat($file);
michael@428:     return ($stat[7], $stat[9]);
michael@428: }
michael@428: 
michael@428: sub digest ($) {
michael@428:     my ($file) = @_;
michael@428:     my $digest = "";
michael@428:     my $output = `($OPENSSL md5 -hex "$file") 2>/dev/null || true`;
michael@428:     if ($output =~ m/MD5\(.+?\)=\s*([0-9a-fA-F]+)/s) {
michael@428:         $digest = uc($1);
michael@428:     }
michael@428:     return $digest;
michael@428: }
michael@428: 
michael@428: sub write_index ($$$$$$) {
michael@428:     my ($fh, $prefix, $resource, $platform, $list, $cache) = @_;
michael@428:     my ($a, $h, $r, $spec, $T, $D);
michael@428: 
michael@428:     foreach (@$list) {
michael@428:         $a = undef;
michael@428:         $h = undef;
michael@428:         $r = undef;
michael@428:         $S = undef;
michael@428:         $T = undef;
michael@428:         $D = undef;
michael@428:         $o = undef;
michael@428: 
michael@428:         #   determine information
michael@428:         if (m/\.spec$/) {
michael@428:             $spec = readfile($_);
michael@428:             $a = spec2data($spec);
michael@428:             ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
michael@428:             $D = digest($_) if ($opt_D);
michael@428:         } elsif (m/([^\/]+\.(?:no)?src\.rpm)$/) {
michael@428:             $h = relpath($prefix, $_);
michael@428:             ($S, $T) = sizetime($_) if ($opt_S or $opt_T or $cache);
michael@428:             if ($cache) {
michael@428:                 if (   exists($cache->{"T$_"})
michael@428:                     && $cache->{"T$_"} == $T
michael@428:                     && exists($cache->{"s$_"})
michael@428:                     && $cache->{"s$_"} ne ""
michael@428:                     && (!$opt_S || ($opt_S && exists($cache->{"S$_"}) && $cache->{"S$_"} ne ""))
michael@428:                     && (!$opt_D || ($opt_D && exists($cache->{"D$_"}) && $cache->{"D$_"} ne ""))) {
michael@428:                     #   found in cache
michael@428:                     $spec = $cache->{"s$_"};
michael@428:                     $S = $cache->{"S$_"} if ($opt_S);
michael@428:                     $D = $cache->{"D$_"} if ($opt_D);
michael@428:                 } else {
michael@428:                     #   not found in cache
michael@428:                     $spec = rpm2spec($_);
michael@428:                     $cache->{"s$_"} = $spec;
michael@428:                     $cache->{"S$_"} = $S;
michael@428:                     $cache->{"T$_"} = $T;
michael@428:                     $D = digest($_)      if ($opt_D);
michael@428:                     $cache->{"D$_"} = $D if ($opt_D);
michael@428:                 }
michael@428:             } else {
michael@428:                 #   no cache at all
michael@428:                 $spec = rpm2spec($_);
michael@428:                 $D = digest($_) if ($opt_D);
michael@428:             }
michael@428:             $a = spec2data($spec);
michael@428:         } elsif (m/([^\/]+\.rpm)$/) {
michael@428:             $h = relpath($prefix, $_);
michael@428:             $a = rpm2data($_, $platform);
michael@428:             ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
michael@428:             $D = digest($_) if ($opt_D);
michael@428:         } elsif (m/(([^\/]+)\.(?:no)?src\.sh)$/) {
michael@428:             $h = relpath($prefix, $_);
michael@428:             ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
michael@428:             $D = digest($_) if ($opt_D);
michael@428:             $o = "$2:bootstrap";
michael@428:         } elsif (m/([^\/]+\.rdf[^\/]*)$/) {
michael@428:             $h = relpath($prefix, $_);
michael@428:             $r = getresource($_) || $resource.dirname($h);
michael@428:             ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
michael@428:             $D = digest($_) if ($opt_D);
michael@428:         }
michael@428: 
michael@428:         #   process information
michael@428:         if ($a) {
michael@428:             xml_record($fh, $a, $h, $S, $T, $D);
michael@428:         } elsif ($o) {
michael@428:             xml_other($fh, $o, $h, $S, $T, $D);
michael@428:         } elsif ($r) {
michael@428:             xml_reference($fh, $r, $h, $S, $T, $D);
michael@428:         } else {
michael@428:             warn "openpkg:index:ERROR: cannot process $_";
michael@428:         }
michael@428:     }
michael@428: }
michael@428: