openpkg-packages/openpkg-tool/openpkg-index.pl

##
##  openpkg-index.pl -- OpenPKG Maintenance Tool (backend for indexing)
##  Copyright (c) 2000-2003 The OpenPKG Project <http://www.openpkg.org/>
##  Copyright (c) 2000-2003 Ralf S. Engelschall <rse@engelschall.com>
##  Copyright (c) 2000-2003 Cable & Wireless <http://www.cw.com/>
##
##  Permission to use, copy, modify, and distribute this software for
##  any purpose with or without fee is hereby granted, provided that
##  the above copyright notice and this permission notice appear in all
##  copies.
##
##  THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
##  SUCH DAMAGE.
##

require 5;

use strict;

use Getopt::Std;
getopts('r:p:C:o:ci');
use vars qw/$opt_r $opt_p $opt_C $opt_o $opt_c $opt_i/;

use FileHandle;
use DirHandle;

my $l_prefix = '@l_prefix@';
my $RPM = "$l_prefix/bin/rpm";
my $R2C = "$l_prefix/bin/rpm2cpio";
my $BZ  = "$l_prefix/lib/openpkg/bzip2 -9";

#########################################################################

#
# escape XML special characters for output in RDF file
#
# remove trailing whitespace
# remove common leading whitespace
#
sub e ($) {
    my($s) = @_;
    my($i);

    $s =~ s/\n+$//sg;
    $s =~ s/[^\S\n]+$//mg;

    $i = undef;
    while ($s =~ /^([^\S\n]+)/mg) {
        $i = $1 if !defined $i || length($1) < length($i);
    }

    $s =~ s/^\Q$i\E//mg if defined $i;
    $s =~ s/&/&amp;/sg;
    $s =~ s/</&lt;/sg;
    $s =~ s/>/&gt;/sg;

    return $s;
}

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;

sub make_resource ($) {
    my($s) = @_;

    if ($s =~ /(\S+)\s*($opreg)\s*(.*?)\s*$/o) {
        return {
            resource  => $1,
            attrname  => $attrname{$2},
            attrval   => $3
        } 
    }

    return {
        resource => $s
    }
}

sub commasep ($$) {
    my($k,$v) = @_;

    if ($k =~ /^(NoSource)$/) {
        return split(/\s*,\s*/, $v);
    } elsif ($k =~ /^(PreReq|BuildPreReq|Provides|Conflicts)$/) {
        return map { make_resource($_) }
               split(/\s*,\s*/, $v);
    }

    return $v;
}

sub optesc ($) {
    my($s) = @_;

    $s =~ s/([\x00-\x1f\x80-\xbf\s\%])/sprintf("%%%02x",ord($1))/eg;

    return $s;
}

sub vsub ($$) {
    my($var,$v) = @_;

    $v =~ s/\%\{([^}]+)\}/
        exists $var->{$1} ? $var->{$1} : '%{'.$1.'}'/emg;

    return $v;
}

sub upn ($) {
    my($t) = @_;
    my(@tok) = $t =~ /(\(|\)|\&\&|\|\||\!|\S+)/g;
    my(@out,$op,$o);
    my(@save);

    $op = [];
    foreach (@tok) {
        if ($_ eq '(') {
            push @save, $op;
            $op = [];
        } elsif ($_ eq ')') {
            die "FATAL: unresolved operators in: @tok\n" if @$op;
            $op = pop @save
                or die "FATAL: parenthesis stack underflow in: @tok\n";
            while ($o = pop @$op) {
                push @out, $o->[0];
                last if $o->[1];
            }
        } elsif ($_ eq '&&') {
            push @$op, [ '+', 1 ] ;
        } elsif ($_ eq '||') {
            push @$op, [ '|', 1 ] ;
        } elsif ($_ eq '!') {
            push @$op, [ '!', 0 ];
        } elsif (/^\%\{(\S*?)\}$/) {
            push @out, $1;
            while ($o = pop @$op) {
                push @out, $o->[0];
                last if $o->[1]; # binop
            }
        }
    }

    return join (' ',@out);
}

#
# deduce external variables from description
#
# 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 #if/#ifdef/#define
#
# #defines are interpolated (correct ?)
#
# #if/#ifdef/... sections are stripped
# result is the same as if all conditions evaluate false (!)
#
# all attributes are of the form key: value
# repeated attributes are coalesced into a list
#
sub package2data ($$) {
    my($s,$ovar) = @_;
    my(%evar,%var);
    my(@term, $term);
    my(%attr,%avar);
    my($l, $v, $cond, $d, $p);
    my($re,@defs);

    # combine multilines
    $s =~ s/\\\n/ /sg;

    #
    # map conditional variable macros
    #
    $s =~ s/^#\{\!\?([^:]*):\s*%(.*?)\s*\}\s*$/#ifndef $1\n#$2\n#endif/mg;
    $s =~ s/^#\{\!\?([^:]*):\s*(.*?)\s*\}\s*$/#ifndef $1\n$2\n#endif/mg;

    #
    # map 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 interpolation
    #
    %evar = %$ovar;

    #
    # guess more external parameters by scanning for "default" sections.
    #
    $re = '^\#ifndef\s+[\w\_]+\s*\n((?:\#define\s+[\w\_]+\s.*\n)+)\#endif\n';
    @defs = $s =~ /$re/gm;
    foreach (@defs) {
        while (/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
            $ovar->{$1} = $2;
            $evar{$1} = '%{'.$1.'}';
        }
    }
    $s =~ s/$re//gm;

    #
    # add everything looking like a with_ variable
    #
    $re = '%{(with\_[\w\_]+)}';
    @defs = $s =~ /$re/gm;
    foreach (@defs) {
        next if exists $ovar->{$1};
        $ovar->{$1} = '%{'.$1.'}';
        $evar{$1} = '%{'.$1.'}';
    }

    #
    # extract all conditional sections
    #
    @term = ();
    %var  = ();
    $cond = '';
    foreach $l (split(/\n/, $s)) {
        $v = vsub(\%avar, vsub(\%var, $l));

        if (($p) = $v =~ /^\#if\s+(.*?)\s*$/) {
            #
            # normalize #if expressions
            # "%{variable}" == "yes"
            # "%{variable}" == "no"
            # operators ! && ||
            #
            $term = '';
            while ($p =~ /(!=)|(\!|\|\||\&\&|\(|\))|"\%\{([^}]+)\}"\s*==\s*"(yes|no)"|(\S+)/g) {
                if (defined $1) {
                    warn "WARNING: unknown token '$1':\n< $l\n> $v\n";
                } elsif (defined $5) {
                    warn "WARNING: unknown token '$5':\n< $l\n> $v\n";
                } elsif (defined $2) {
                    $term .= " $2 ";
                } elsif (exists $evar{$3}) {
                    $term .= ($4 eq 'no' ? '! ' : '').vsub(\%evar,'%{'.$3.'}');
                } else {
                    warn "WARNING: unknown conditional '$3':\n< $l\n> $v\n";
                }
            }

            #
            # join with previous conditions for this #if/#endif block
            #
            if ($term ne '') {
                push @term, "( $term )";
                $cond = join(' && ', grep { $_ ne '' } @term).'';
            } else {
                push @term, '';
            }
        } elsif ($v =~ /^\#else\s*$/) {
            #
            # reverse last condition
            #
            if (@term) {
                $term[-1] = ' ! '.$term[-1];
                $cond = join(' && ', grep { $_ ne '' } @term).'';
            } else {
                die "FATAL: else without if\n";
            }
        } elsif ($v =~ /^\#endif\s*$/) {
            #
            # unwind last #if expression
            #
            pop @term;
            $cond = join(' && ', grep { $_ ne '' } @term).'';

        } elsif ($v =~ /^\#(?:define)\s*(\S+)\s*(.*?)\s*$/) {

            #
            # define conditional variables
            # truth-value becomes current condition
            #
            # define internal variables
            # -> store for subsequent substitution
            #
            if (exists $evar{$1}) {
                if ($2 eq 'yes') {
                    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 "WARNING: logic too complex for '$1':\n< $l\n> $v\n";
                }
            } else {
                $var{$1} = $2;
            }
        } elsif ($v =~ /^\#(?:undefine)\s*(\S+)\s*$/) {
            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 "ERROR: no package name set for option $1 = $2\n";
            }

        } 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 for current condition
            #
            push @{$attr{$1}->{$cond}}, commasep($1,$2);
            $avar{lc($1)} = $2 if $cond eq '';
        }
    }

    return \%attr;
}

#
# split spec file into sections starting with a %word
#
# concatenate extended lines
# strip comment lines
# map %command to #command
# split sections
#
# return package2data from default section.
#
sub spec2data ($) {
    my($s) = @_;
    my(%map);
    my($a,$o);
    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(/^(?=%\w+\s*\n)/m, $s)) {
        if (/^%(\w+)\s*\n/) {
            $map{$1} .= $';
        } else {
            $map{'*'} .= $_;
        }
    }

    if (exists $map{'description'}) {
        $o = find_options($map{'description'});
        $a = package2data($map{'*'}, $o );
        $a->{'Description'} = { '' => [ $map{'description'} ] };
    } else {
        $a = package2data($map{'*'}, {});
    }

    return $a;
}

##########################################################################

#
# start of XML file
#
sub xml_head ($$) {
    my($fh,$res) = @_;
    print $fh <<EOFEOF;
<?xml version="1.0" encoding="iso-8859-1"?>
<rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
         xmlns="http://www.openpkg.org/xml-rdf-index/0.9">
  <Repository rdf:resource="$res">
EOFEOF
}

#
# end of XML file, corresponds with start tags
#
sub xml_foot ($) {
    my($fh) = @_;
    print $fh <<EOFEOF;
  </Repository>
</rdf:RDF>
EOFEOF
}

sub n($$) {
    my($a,$k) = @_;
    return unless $a->{$k};
    return unless $a->{$k}->{''};
    return $a->{$k}->{''}->[0];
}

#
# send out $a->{$k} as text-style tag
#
sub xml_text ($$$;$) {
    my($i,$a,$k,$tag) = @_;
    my($out);
    return "" unless exists $a->{$k};
    $tag = $k unless defined $tag;
    $i = ' ' x $i;

    $out = e(n($a,$k));

    return if $out eq '';

    return "$i<$tag>\n$out\n$i</$tag>\n";
}

#
# send out @{$a->{$k}} as body of an XML tag
# $k is the name of the tag unless overridden by $tag
# $i denotes the depth of indentation to form nicely
# looking files.
#
# all data from the list is flattened into a single
# body, separated by LF and escaped for XML metachars.
#
sub xml_tag ($$$;$) {
    my($i,$a,$k,$tag) = @_;
    my($out,$cond,$upn);
    return "" unless exists $a->{$k};
    $tag = $k unless defined $tag;
    $out = '';
    $i = ' ' x $i;

    foreach $cond (sort keys %{$a->{$k}}) {
        $upn = e(upn($cond));
        $out .= $i.
            ($cond ne '' ?  "<$tag cond=\"$upn\">" : "<$tag>").
            join("\n", map { e($_) } @{$a->{$k}->{$cond}}).
            "</$tag>\n";
    }
    
    return $out;
}

#
# send out @{$a->{$k}} as a rdf:bag
# $k is the name of the outer tag unless overriden by $tag
# $i denotes the depth of indentation, inner tags are indented
# 2 or 4 more character positions.
#
# each element of the bag is listed
#
sub xml_bag ($$$;$) {
    my($i,$a,$k,$tag) = @_;
    my($out,$cond,$upn);
    return "" unless exists $a->{$k};
    $tag = $k unless defined $tag;
    $out = '';
    $i = ' ' x $i;

    foreach $cond (sort keys %{$a->{$k}}) {
        next unless @{$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) = @_;

    print $fh <<EOFEOF;
    <Repository rdf:resource="$res" href="$href"/>
EOFEOF
}

#
# translate attributes from %$a as generated by package2data
# into XML and write to file $fh
#
sub xml_record ($$$) {
    my($fh, $a, $href) = @_;
    my($maj,$min,$rel,$about);

    $about =
        n($a,'Name').'-'.
        n($a,'Version').'-'.
        n($a,'Release');

    unless (defined $href) {

        # guess location from Information in Specfile

        if (exists $a->{'NoSource'}) {
            $href = "$about.nosrc.rpm";
        } else {
            $href = "$about.src.rpm";
        }
        ($maj,$min,$rel) = n($a,'Release') =~ /^(\d+)\.(\d+)\.(\d+)/;

        if (defined $min) {
            if ($maj > 1 || ($maj == 1 && $min > 0)) {
                # 1.1 or later
                if (n($a,'Distribution') =~ /\[PLUS\]/) {
                    $href = 'PLUS/'.$href;
                }
            }
            if ($maj > 1 || ($maj == 1 && $min >= 0)) {
                # 1.0 or later 
                if ($rel > 0) {
                    $href = 'UPD/'.$href;
                }
            }
        } else {
            # current
        }

    }
    
    print $fh <<EOFEOF;
    <rdf:Description about="$about" href="$href">
EOFEOF

    # fake Source attribute from Source\d attribtutes
    # XXX only default conditional
    $a->{'Source'} = { '' => [
        map {
            s/\Q%{name}\E/n($a,'Name')/esg;
            s/\Q%{version}\E/n($a,'Version')/esg;
            s/\Q%{release}\E/n($a,'Release')/esg;
            #s/.*\///;
            $_;
        }
        map {
            $a->{$_}->{''} ? @{$a->{$_}->{''}} : ()
        }
        sort {
            my($x) = $a =~ /^(\d*)$/;
            my($y) = $b =~ /^(\d*)$/;
            return $x <=> $y;
        }
        grep {
            /^Source\d*$/
        } keys %$a
    ]};
    delete $a->{'Source'} unless @{$a->{'Source'}->{''}};

    print $fh
        xml_tag(6, $a, 'Name'),
        xml_tag(6, $a, 'Version'),
        xml_tag(6, $a, 'Release'),
        xml_tag(6, $a, 'Distribution'),
        xml_tag(6, $a, 'Group'),
        xml_tag(6, $a, 'License'),
        xml_tag(6, $a, 'Packager'),
        xml_tag(6, $a, 'Summary'),
        xml_tag(6, $a, 'URL'),
        xml_tag(6, $a, 'Vendor'),
        xml_tag(6, $a, 'SourceRPM'),
        xml_tag(6, $a, 'Arch'),
        xml_tag(6, $a, 'Os'),
        xml_tag(6, $a, '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 <<EOFEOF;
    </rdf:Description>
EOFEOF
}

#####################################################################

sub rpm2spec ($) {
    my($fn) = @_;
    local($SIG{'PIPE'}) = 'IGNORE';
    my($pipe) = new FileHandle "$R2C '$fn' |"
        or die "FATAL: cannot read '$fn' ($!)\n";
    my($buf,@hdr,$n,$m,$name,$step);
    my($spec);

    while (read($pipe,$buf,110) == 110) {
        @hdr = unpack('a6a8a8a8a8a8a8a8a8a8a8a8a8a8',$buf);
        $n = hex($hdr[12]);      # filename length
        $m = int(($n+5)/4)*4-2;  # filename size (padded)
        last unless read($pipe,$buf,$m) == $m;
        $name = substr($buf,0,$n-1);
        $n = hex($hdr[7]);       # file length
        $m = int(($n+3)/4)*4;    # file size (padded)
        if ($name !~ /.spec$/) {
            while ($m > 0) {
                $step = $m > 8192 ? 8192 : $m;
                last unless read($pipe,$buf,$step);
                $m -= length($buf);
            }
        } else {
            if (read($pipe,$buf,$n) == $n) {
                $spec = $buf;
            }
            last;
        }
    }
    $pipe->close;

    return $spec;
}

#####################################################################

sub rpm2data ($$) {
    my($fn,$platform) = @_;
    my($q,$pipe,%a);
    my($t,$v);

    unless (defined $platform) {
        die "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}
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

    $pipe = new FileHandle "$RPM -qp --qf '$q' '$fn' |"
        or die "FATAL: cannot read '$fn' ($!)\n";
    while (<$pipe>) {
        if (/^(\S+)\s+(.*?)\s*$/) {
            $t = $1;
            $v = $2;
        } elsif (/^(\s+.+?)\s*$/) {
            next unless defined $t;
            $v = $1;
        } else {
            $t = undef;
            next;
        }

        if (exists $a{$t}) {
            $a{$t} .= "\n$v";
        } else {
            $a{$t} = $v;
        }
    }
    $pipe->close;

    %a = map { $_ => $a{$_} }
         grep { $a{$_} ne '(none)' }
         keys %a;
    if ($a{'Relocations'} eq '(non relocatable)') {
        delete $a{'Relocations'};
    }
    if ($a{'SigMD5'} eq '(unknown type)') {
        delete $a{'SigMD5'};
    }
    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 };
}

#####################################################################

sub getindex ($) {
    my($dir) = @_;
    my(@idx) = sort { -M $a <=> -M $b; }
               grep { -f $_ }
                ( <$dir/00INDEX.rdf>, <$dir/00INDEX.rdf.*> );

    return unless @idx;
    return $idx[0];
}

sub list_specdir ($) {
    my($dir) = @_;
    my($dh,$d,$path);
    my(@list);

    $dh = new DirHandle($dir);
    while ($d = $dh->read) {
        next if $d =~ /^\./;
        $path = "$dir/$d/$d.spec";
        push @list, $path if -f $path;
    }

    return \@list;
}

sub list_rpmdir ($) {
    my($dir) = @_;
    my($dh,$d,$path);
    my(@list,$idx,$sub);

    $dh = new DirHandle($dir);
    while ($d = $dh->read) {
        next if $d =~ /^\./;
        $path = "$dir/$d";
        if (-d $path) {
            $idx = getindex($path);
            if (defined $idx) {
                push @list, $idx;
            } else {
                $sub = list_rpmdir($path);
                push @list, @$sub;
                undef $sub;
            }
        } else {
            next unless $d =~ /\.rpm$/ && -f $path;
            push @list, $path;
        }
    }

    return \@list;
}

#####################################################################

sub readfile ($) {
    my($fn) = @_;
    my($fh) = new FileHandle "< $fn"
        or die "FATAL: cannot read '$fn' ($!)\n";
    my(@l) = <$fh>;
    $fh->close;
    return join('',@l);
}

sub relpath ($$) {
    my($prefix,$path) = @_;
    $path =~ s/^\Q$prefix\E\///s;
    return $path;
}

sub dirname ($) {
    my($path) = @_;
    $path =~ s/\/[^\/]*$//s;
    return $path.'/';
}

sub getresource ($) {
    my($fn) = @_;
    my($fh, $buf);

    if ($fn =~ /\.bz2$/) {
        $fh = new FileHandle "$BZ -dc $fn |"
            or die "FATAL: cannot read '$fn' ($!)\n";
    } else {
        $fh = new FileHandle "< $fn"
            or die "FATAL: cannot read '$fn' ($!)\n";
    }
    $fh->read($buf, 1024);
    $fh->close;

    if ($buf =~ /<Repository.*?rdf:resource="([^"]+)"/) {
        return $1;
    }

    return undef;
}

#####################################################################

sub write_index ($$$$$$) {
    my($fh,$prefix,$resource,$platform,$list,$cache) = @_;
    my($a,$h,$r,$spec);
    my($mtime);

    foreach (@$list) {
        $a = undef;
        $h = undef;
        $r = undef;
        if (/\.spec$/) {
            $spec = readfile($_);
            $a    = spec2data($spec);
        } elsif (/([^\/]+\.(?:no)?src\.rpm)$/) {
            $h    = relpath($prefix, $_);
            if ($cache) {
                $mtime = (stat $_)[9];
                if (exists $cache->{"M$_"} &&
                    $cache->{"M$_"} == $mtime) {
                    $spec = $cache->{"S$_"};
                } else {
                    $spec = rpm2spec($_);
                    $cache->{"S$_"} = $spec;
                    $cache->{"M$_"} = $mtime;
                }
            } else {
                $spec = rpm2spec($_);
            }
            $a    = spec2data($spec);
        } elsif (/([^\/]+\.rpm)$/) {
            $h    = relpath($prefix, $_);
            $a    = rpm2data($_, $platform);
        } elsif (/([^\/]+\.rdf[^\/]*)$/) {
            $h    = relpath($prefix, $_);
            $r    = getresource($_) || $resource.dirname($h);
        }

        if ($a) {
            xml_record($fh, $a, $h);
        } elsif ($r) {
            xml_reference($fh, $r, $h);
        } else {
            warn "ERROR: cannot process $_\n";
        }
    }
}

#####################################################################

my($prefix,$list,$fh,%cache,$tmpo);

if ($#ARGV < 0) {
    print "openpkg:index:USAGE: $0 [-r resource] [-p platform] [-C cache.db] [-o index.rdf] [-c] [-i] dir ...\n";
    die "\n";
}

if ($opt_C) {
    eval {
        require DB_File;
    };
    if ($@) {
        die "Sorry. The -C option requires an installed DB_File perl module.\n";
    }
    tie %cache, 'DB_File', $opt_C, O_CREAT|O_RDWR, 0666, $DB_File::DB_HASH
        or die "FATAL: cannot tie cache '$opt_C' ($!)\n";
}

$opt_r = 'OpenPKG-CURRENT/Source/' unless defined $opt_r;

if (defined $opt_o) {
    $tmpo = $opt_o . '.tmp';
    if ($opt_c) {
        $fh = new FileHandle "| $BZ -c > '$tmpo'"
            or die "FATAL: cannot write '$tmpo' ($!)\n";
    } else {
        $fh = new FileHandle "> $tmpo"
            or die "FATAL: cannot write '$tmpo' ($!)\n";
    }
} else {
    if ($opt_c) {
        $fh = new FileHandle "| $BZ -c"
            or die "FATAL: cannot write to stdout ($!)\n";
    } else {
        $fh = new FileHandle ">&=1"
            or die "FATAL: cannot write to stdout ($!)\n";
    }
}

xml_head($fh, $opt_r);
foreach $prefix (@ARGV) {
    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);

$fh->close
    or die "FATAL: write error on output ($!)\n";

if (defined $tmpo) {
    rename $tmpo,$opt_o
        or die "FATAL: cannot rename $tmpo to $opt_o ($!)\n";
}