openpkg/index.pl@a2c6460cfb16
openpkg/index.pl
Mon, 28 Jan 2013 17:37:18 +0100
- author
- Michael Schloh von Bennewitz <michael@schloh.com>
- date
- Mon, 28 Jan 2013 17:37:18 +0100
- changeset 758
- a2c6460cfb16
- permissions
- -rw-r--r--
Correct socket error reporting improvement with IPv6 portable code,
after helpful recommendation by Saúl Ibarra Corretgé on OSips devlist.
1 ##
2 ## index.pl -- OpenPKG Maintenance Tool (backend for indexing)
3 ## Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/>
4 ##
5 ## This software is property of the OpenPKG GmbH, DE MUC HRB 160208.
6 ## All rights reserved. Licenses which grant limited permission to use,
7 ## copy, modify and distribute this software are available from the
8 ## OpenPKG GmbH.
9 ##
10 ## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED
11 ## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
12 ## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
13 ## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
14 ## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
15 ## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
16 ## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
17 ## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
18 ## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
19 ## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
20 ## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
21 ## SUCH DAMAGE.
22 ##
24 #############################################################################
25 ##
26 ## MAIN PROCEDURE
27 ##
28 #############################################################################
30 require 5;
31 #use strict;
33 # determine OpenPKG instance prefix via
34 # 1. the environment of the "openpkg build" framework
35 # 2. the installation path of the script
36 # 3. the installation path of the Perl interpreter
37 # 4. the path of the "openpkg" command in $PATH
38 my $l_prefix = $ENV{'OPENPKG_PREFIX'};
39 if (not $l_prefix) {
40 ($l_prefix) = ($0 =~ m/^(.+)\/lib(exec)?\/openpkg(-tools)?\/build(\.pl)?$/);
41 }
42 if (not $l_prefix) {
43 ($l_prefix) = ($^X =~ m/^(.+)\/bin\/perl.*$/);
44 }
45 if (not $l_prefix) {
46 $l_prefix = (`(which openpkg) 2>/dev/null` =~ m/^(.+)\/bin\/openpkg$/);
47 }
48 if (not -x "$l_prefix/bin/openpkg") {
49 die "openpkg:index:FATAL: cannot determine OpenPKG instance prefix";
50 }
52 # determine tools
53 my $RPM = ((-f "$l_prefix/bin/openpkg" && -f "$l_prefix/libexec/openpkg/rpm") ?
54 "$l_prefix/bin/openpkg rpm" : "$l_prefix/bin/rpm");
55 my $R2C = ((-f "$l_prefix/bin/openpkg" && -f "$l_prefix/libexec/openpkg/rpm2cpio") ?
56 "$l_prefix/bin/openpkg rpm2cpio" : "$l_prefix/bin/rpm2cpio");
57 my $BZ = "$l_prefix/lib/openpkg/bzip2 -9";
58 my $OPENSSL = "$l_prefix/lib/openpkg/openssl";
60 # parse command line
61 our ($opt_r, $opt_p, $opt_S, $opt_T, $opt_D, $opt_C, $opt_o, $opt_c, $opt_i);
62 my $getopts = 'r:p:STDC:o:ci';
63 getopts($getopts);
64 if ($#ARGV < 0) {
65 print "openpkg:index:USAGE: openpkg index [-r resource] [-p platform] [-S] [-T] [-D] [-C cache.db] [-o index.rdf] [-c] [-i] dir ...\n";
66 exit(1);
67 }
69 # optionally open cache file
70 my %cache;
71 if ($opt_C) {
72 eval {
73 require DB_File;
74 };
75 if ($@) {
76 die "openpkg:index:FATAL: The -C option requires an installed DB_File perl module.";
77 }
78 eval {
79 require Fcntl;
80 };
81 if ($@) {
82 die "openpkg:index:FATAL: The -C option requires an installed Fcntl perl module.";
83 }
84 tie %cache, 'DB_File', $opt_C, Fcntl::O_CREAT()|Fcntl::O_RDWR(), 0666, $DB_File::DB_HASH
85 or die "openpkg:index:FATAL: cannot tie cache '$opt_C' ($!)";
86 }
88 # provide default for repository path
89 $opt_r = 'OpenPKG-CURRENT/Source/' if (not defined($opt_r));
91 # create make_resource function closure
92 my $make_resource = gen_make_resource();
94 # determine output channel
95 my $fh;
96 my $tmpo;
97 if (defined($opt_o)) {
98 $tmpo = $opt_o . '.tmp';
99 if ($opt_c) {
100 open(FH, "| $BZ -c > '$tmpo'")
101 or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
102 } else {
103 open(FH, "> $tmpo")
104 or die "openpkg:index:FATAL: cannot write '$tmpo' ($!)";
105 }
106 } else {
107 if ($opt_c) {
108 open(FH, "| $BZ -c")
109 or die "openpkg:index:FATAL: cannot write to stdout ($!)";
110 } else {
111 open(FH, ">&=1")
112 or die "openpkg:index:FATAL: cannot write to stdout ($!)";
113 }
114 }
115 $fh = \*FH;
117 # generate XML/RDF output
118 xml_head($fh, $opt_r);
119 foreach my $prefix (@ARGV) {
120 my $list;
121 if (-d $prefix) {
122 if ($opt_i) {
123 $list = list_rpmdir($prefix);
124 } else {
125 $list = list_specdir($prefix);
126 }
127 } else {
128 $list = [ $prefix ];
129 $prefix = dirname($prefix);
130 }
131 write_index($fh, $prefix, $opt_r, $opt_p, $list, $opt_C ? \%cache : undef);
132 }
133 xml_foot($fh);
135 # close output channel
136 close($fh)
137 or die "openpkg:index:FATAL: write error on output ($!)";
139 # post-process output
140 if (defined($tmpo)) {
141 rename($tmpo, $opt_o)
142 or die "openpkg:index:FATAL: cannot rename $tmpo to $opt_o ($!)";
143 }
145 # die gracefully
146 exit(0);
148 #############################################################################
149 ##
150 ## FUNCTIONS: PARSING
151 ##
152 #############################################################################
154 # home-brewn getopt(3) style option parser
155 sub getopts ($) {
156 my ($opts) = @_;
157 my (%optf) = map { m/(\w)/; $1 => $_ } $opts =~ m/(\w:|\w)/g;
158 my (%opts, @argv, $optarg);
160 foreach (@ARGV) {
161 if (@argv) {
162 push @argv, $_;
163 } elsif (defined $optarg) {
164 if (exists $opts{$optarg}) {
165 $opts{$optarg} .= " $_";
166 } else {
167 $opts{$optarg} = $_;
168 }
169 $optarg = undef;
170 } elsif (!/^[-]/) {
171 push @argv, $_;
172 } else {
173 while (/^\-(\w)(.*)/) {
174 if (exists $optf{$1}) {
175 if (length($optf{$1}) > 1) {
176 if ($2 ne '') {
177 if (exists $opts{$1}) {
178 $opts{$1} .= " $2";
179 } else {
180 $opts{$1} = $2;
181 }
182 } else {
183 $optarg = $1;
184 }
185 last;
186 } else {
187 $opts{$1} = 1;
188 }
189 } else {
190 warn "openpkg:index:WARNING: unknown option $_\n";
191 }
192 $_ = "-$2";
193 }
194 }
195 }
196 if (defined $optarg) {
197 warn "openpkg:index:WARNING: option $optarg requires an argument\n";
198 }
199 foreach (keys %opts) {
200 eval '$opt_'.$_.' = "'.quotemeta($opts{$_}).'";';
201 }
202 @ARGV = @argv;
203 }
205 #############################################################################
206 ##
207 ## OpenPKG RPM Package Specification Parsing
208 ##
209 #############################################################################
211 # escape XML for output in RDF file
212 sub e ($) {
213 my ($s) = @_;
214 my ($i);
216 # remove trailing whitespace
217 $s =~ s/\n+$//sg;
218 $s =~ s/[^\S\n]+$//mg;
220 # remove common leading whitespace
221 $i = undef;
222 while ($s =~ m/^([^\S\n]+)/mg) {
223 $i = $1 if (!defined($i) || (length($1) < length($i)));
224 }
225 $s =~ s/^\Q$i\E//mg if (defined($i));
227 # escape XML special characters
228 $s =~ s/&/&/sg;
229 $s =~ s/</</sg;
230 $s =~ s/>/>/sg;
232 return $s;
233 }
235 # make_resource closure
236 sub gen_make_resource {
237 # generate operator regular expression
238 # (used in make_resource below)
239 my %attrname = (
240 '==' => 'equ',
241 '=' => 'equ',
242 '>=' => 'geq',
243 '=>' => 'geq',
244 '<=' => 'leq',
245 '=<' => 'leq',
246 '>' => 'gt',
247 '<' => 'lt'
248 );
249 my ($opreg) =
250 join '|',
251 map {
252 "\Q$_\E"
253 } sort {
254 length($b) <=> length($a)
255 || $b cmp $a
256 } keys(%attrname);
258 # return function which makes resource object
259 return sub ($) {
260 my ($s) = @_;
262 if ($s =~ m/(\S+)\s*($opreg)\s*(.*?)\s*$/o) {
263 return {
264 resource => $1,
265 attrname => $attrname{$2},
266 attrval => $3
267 }
268 }
269 else {
270 return {
271 resource => $s
272 }
273 }
274 };
275 };
277 # split string into array at comma seperator
278 # (optioanlly map resource operators into resource objects)
279 sub commasep ($$) {
280 my ($k, $v) = @_;
282 if ($k =~ m/^(NoSource)$/) {
283 return split(/\s*,\s*/, $v);
284 } elsif ($k =~ /^(PreReq|BuildPreReq|Provides|Conflicts)$/) {
285 return map { &$make_resource($_) }
286 split(/\s*,\s*/, $v);
287 }
288 return $v;
289 }
291 # escape option string
292 sub optesc ($) {
293 my ($s) = @_;
295 $s =~ s/([\x00-\x1f\x80-\xbf\s\%])/sprintf("%%%02x", ord($1))/eg;
296 return $s;
297 }
299 # variable substitution
300 sub vsub ($$) {
301 my ($var, $v) = @_;
303 $v =~ s/\%\{([^}]+)\}/
304 exists $var->{$1} ? $var->{$1} : '%{'.$1.'}'/emg;
305 return $v;
306 }
308 # Umgekehrte Polnische Notation (UPN)
309 # Reverse Polish Notation (RPN)
310 # << ( %{foo} == "yes" ) && ( ! %{bar} == "no" ) || ( %{baz} == "yes" )
311 # >> %{foo} %{bar} ! && %{baz} ||
312 sub upn ($) {
313 my ($t) = @_;
314 my (@tok);
315 my (@out, $op, $o);
316 my (@save);
318 # split string into tokens
319 @tok = ($t =~ m/(\(|\)|\&\&|\|\||\!|\S+)/g);
321 # iterate over all tokens
322 $op = [];
323 foreach (@tok) {
324 if ($_ eq '(') {
325 push(@save, $op);
326 $op = [];
327 } elsif ($_ eq ')') {
328 die "openpkg:index:FATAL: unresolved operators in: @tok\n" if (@$op);
329 $op = pop(@save)
330 or die "openpkg:index:FATAL: unmatched closing parenthesis in: @tok\n";
331 while ($o = pop(@$op)) {
332 push(@out, $o->[0]);
333 last if ($o->[1]);
334 }
335 } elsif ($_ eq '&&') {
336 push(@$op, [ '+', 1 ]);
337 } elsif ($_ eq '||') {
338 push(@$op, [ '|', 1 ]);
339 } elsif ($_ eq '!') {
340 push(@$op, [ '!', 0 ]);
341 } elsif (m/^\%\{(\S*?)\}$/) {
342 push(@out, $1);
343 while ($o = pop(@$op)) {
344 push(@out, $o->[0]);
345 last if ($o->[1]); # binary operator
346 }
347 }
348 }
349 return join (' ', @out);
350 }
352 # deduce external variables from description
353 # (backward compatibility for times before openpkg-20021230)
354 sub find_options ($) {
355 my ($descr) = @_;
356 my $evar = {};
357 $descr =~ s/--define\s*'(\S+)\s*\%\{\1\}'/$evar->{$1} = '%{'.$1.'}', ''/sge;
358 return $evar;
359 }
361 # translate default section from spec-file into a hash
362 # - %if/%ifdef/%define... are translated to #/#ifdef/#define
363 # - #defines are interpolated (correct ?)
364 # - #if/#ifdef/... sections are stripped
365 # result is the same as if all conditions evaluate false (!)
366 # - all attributes are of the form key: value
367 # - repeated attributes are coalesced into a list
368 # hint: evar = expansion variables, ovar = option variables
369 sub package2data ($$) {
370 my ($s, $ovar) = @_;
371 my (%evar, %var);
372 my (@term, $term);
373 my (%attr, %avar);
374 my ($l, $v, $cond, $d, $p);
375 my ($re, @defs);
377 # combine multilines (line continuation!)
378 $s =~ s/\\\n/ /sg;
380 # map syntax of conditional variable macros
381 $s =~ s/^#\{\!\?([^:]*):\s*%(.*?)\s*\}\s*$/#ifndef $1\n#$2\n#endif/mg;
382 $s =~ s/^#\{\!\?([^:]*):\s*(.*?)\s*\}\s*$/#ifndef $1\n$2\n#endif/mg;
384 # map syntax of option macro
385 $s =~ s/^#option\s+(\S+)\s*(.*?)\s*$/#ifndef $1\n#define $1 $2\n#endif\n#provides $1 $2/mg;
387 # use option variables for expansion
388 %evar = %$ovar;
390 # guess more external parameters by scanning for (and removing) "set option default" sections
391 $re = '^\#ifndef\s+[\w\_]+\s*\n((?:\#define\s+[\w\_]+\s.*\n)+)\#endif\n';
392 @defs = ($s =~ m/$re/gm);
393 foreach (@defs) {
394 while (m/^\#define\s+([\w\_]+)\s(.*?)\s*$/mg) {
395 $ovar->{$1} = $2;
396 $evar{$1} = '%{'.$1.'}';
397 }
398 }
399 $s =~ s/$re//gm;
401 # add everything looking like a "with_xxx" variable
402 $re = '%{(with\_[\w\_]+)}';
403 @defs = ($s =~ /$re/gm);
404 foreach (@defs) {
405 next if (exists($ovar->{$1}));
406 $ovar->{$1} = '%{'.$1.'}'; # unexpanded
407 $evar{$1} = '%{'.$1.'}';
408 }
410 # extract all conditional sections (#if/#else/#endif)
411 @term = ();
412 %var = ();
413 $cond = '';
414 foreach $l (split(/\n/, $s)) {
415 # expand variables
416 $v = vsub(\%avar, vsub(\%var, $l));
418 if (($p) = ($v =~ /^\#if\s+(.*?)\s*$/)) {
419 # normalize "%{variable}" != ..."
420 $p =~ s/("\%\{[^}]+\}")\s*!=\s*"(yes|no)"/$1 . " == \"" . ($2 ne "yes" ? "yes" : "no") . "\""/sge;
422 # normalize #if expressions
423 # - "%{variable}" == "yes"
424 # - "%{variable}" == "no"
425 # - operators ! && ||
426 # warn on:
427 # - operator !=
428 # - any other word
429 $term = '';
430 while ($p =~ m/(!=)|(\!|\|\||\&\&|\(|\))|"\%\{([^}]+)\}"\s*==\s*"(yes|no)"|(\S+)/g) {
431 if (defined($1)) {
432 warn "openpkg:index:WARNING: unknown token '$1':\n< $l\n> $v";
433 } elsif (defined($5)) {
434 warn "openpkg:index:WARNING: unknown token '$5':\n< $l\n> $v";
435 } elsif (defined($2)) {
436 $term .= " $2 ";
437 } elsif (exists($evar{$3})) {
438 $term .= ($4 eq 'no' ? '! ' : '').vsub(\%evar, '%{'.$3.'}');
439 } else {
440 warn "openpkg:index:WARNING: unknown condition variable '$3':\n< $l\n> $v";
441 }
442 }
444 # join with previous conditions for this #if/#endif block
445 if ($term ne '') {
446 push(@term, "( $term )");
447 $cond = join(' && ', grep { $_ ne '' } @term) . '';
448 } else {
449 push(@term, '');
450 }
451 }
452 elsif ($v =~ /^\#else\s*$/) {
453 # reverse last condition
454 if (@term) {
455 $term[-1] = ' ! '. $term[-1];
456 $cond = join(' && ', grep { $_ ne '' } @term) . '';
457 } else {
458 die "openpkg:index:FATAL: \"else\" without \"if\"";
459 }
460 }
461 elsif ($v =~ /^\#endif\s*$/) {
462 # unwind last #if expression
463 pop(@term);
464 $cond = join(' && ', grep { $_ ne '' } @term) . '';
465 }
466 elsif ($v =~ /^\#(?:define)\s*(\S+)\s*(.*?)\s*$/) {
467 # define conditional variables
468 # - truth-value becomes current condition
469 # define internal variables
470 # - store for subsequent substitution
471 if (exists($evar{$1})) {
472 if ($2 eq 'yes') {
473 if ($cond eq '') {
474 $evar{$1} = "( \%\{$1\} )";
475 } else {
476 $evar{$1} = "( \%\{$1\} || ( $cond ) )";
477 }
478 } elsif ($2 eq 'no') {
479 if ($cond eq '') {
480 $evar{$1} = "( \%\{$1\} )";
481 } else {
482 $evar{$1} = "( %\{$1\} && ! ( $cond ) )";
483 }
484 } else {
485 warn "openpkg:index:WARNING: logic too complex for '$1' (boolean expressions allowed only):\n< $l\n> $v";
486 }
487 } else {
488 $var{$1} = $2;
489 }
490 }
491 elsif ($v =~ /^\#(?:undefine)\s*(\S+)\s*$/) {
492 # undefine conditional variables
493 # undefine internal variables
494 if (exists($evar{$1})) {
495 $evar{$1} = "\%\{$1\}";
496 } else {
497 delete($var{$1});
498 }
499 }
500 elsif ($v =~ /^\#(?:provides)\s*(\S+)\s*(.*?)\s*$/) {
501 # store option for current condition
502 if (exists($attr{'Name'}->{''})) {
503 push(@{$attr{'Provides'}->{$cond}}, {
504 resource => $attr{'Name'}->{''}->[0] . '::' . $1,
505 attrname => 'equ',
506 attrval => optesc($2)
507 });
508 } else {
509 warn "openpkg:index:ERROR: no package name set for option \"$1 = $2\"";
510 }
511 }
512 elsif ($v =~ /^\#NoSource\s*(.*?)\s*$/) {
513 # store conditional NoSource attribute
514 push(@{$attr{'NoSource'}->{$cond}}, commasep('NoSource', $1));
516 }
517 elsif ($v =~ /^\s*([^\#]\S*)\s*:\s*(.*?)\s*$/) {
518 # store "attribute: value" headers for current condition
519 push(@{$attr{$1}->{$cond}}, commasep($1,$2));
520 $avar{lc($1)} = $2 if ($cond eq '');
521 }
522 }
524 # return all header "attributes"
525 return \%attr;
526 }
528 # split spec file into sections starting with a %word
529 # - concatenate extended lines
530 # - strip comment lines
531 # - map %command to #command
532 # - split sections
533 # - return package2data() from default section (before first %xxx section)
534 sub spec2data ($) {
535 my ($s) = @_;
536 my (%map);
537 my ($a, $o);
538 my $spec = $s;
540 # remove comments
541 $s =~ s/^\s*#.*?\n//mg;
543 # map commands
544 $s =~ s/^%(ifdef|ifndef|if|NoSource|option|undefine|define|else|endif|\{)/#$1/mg;
546 # split sections
547 foreach (split(m/^(?=%\w+\s*\n)/m, $s)) {
548 if (m/^%(\w+)\s*\n/) {
549 $map{$1} .= $';
550 } else {
551 $map{'*'} .= $_;
552 }
553 }
555 # translate package information into "data"
556 if (exists($map{'description'})) {
557 # backward compatibility (options are in description)
558 $o = find_options($map{'description'});
559 $a = package2data($map{'*'}, $o );
560 $a->{'Description'} = { '' => [ $map{'description'} ] };
561 } else {
562 # standard case
563 $a = package2data($map{'*'}, {});
564 }
565 return $a;
566 }
568 #############################################################################
569 ##
570 ## XML/RDF Generation
571 ##
572 #############################################################################
574 # start of XML file
575 sub xml_head ($$) {
576 my ($fh, $res) = @_;
577 print $fh <<EOFEOF;
578 <?xml version="1.0" encoding="iso-8859-1"?>
579 <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
580 xmlns="http://www.openpkg.org/xml-rdf-index/0.9">
581 <Repository rdf:resource="$res">
582 EOFEOF
583 }
585 # end of XML file, corresponds with start tags
586 sub xml_foot ($) {
587 my($fh) = @_;
588 print $fh <<EOFEOF;
589 </Repository>
590 </rdf:RDF>
591 EOFEOF
592 }
594 # conditional expansion of attribute
595 sub n ($$) {
596 my ($a, $k) = @_;
597 return if (not $a->{$k});
598 return if (not $a->{$k}->{''});
599 return ($a->{$k}->{''}->[0]);
600 }
602 # send out $a->{$k} as text-style tag
603 sub xml_text ($$$;$) {
604 my ($i, $a, $k, $tag) = @_;
605 my ($out);
606 return "" if (not exists($a->{$k}));
607 $tag = $k if (not defined($tag));
608 $i = ' ' x $i;
609 $out = e(n($a, $k));
610 return if $out eq '';
611 return "$i<$tag>\n$out\n$i</$tag>\n";
612 }
614 # send out @{$a->{$k}} as body of an XML tag
615 # $k is the name of the tag unless overridden by $tag
616 # $i denotes the depth of indentation to form nicely
617 # looking files.
618 # all data from the list is flattened into a single
619 # body, separated by LF and escaped for XML metachars.
620 sub xml_tag ($$$;$) {
621 my ($i, $a, $k, $tag) = @_;
622 my ($out, $cond, $upn);
623 return "" if (not exists($a->{$k}));
624 $tag = $k if (not defined($tag));
625 $out = '';
626 $i = ' ' x $i;
627 foreach $cond (sort keys(%{$a->{$k}})) {
628 $upn = e(upn($cond));
629 $out .= $i .
630 ($cond ne '' ? "<$tag cond=\"$upn\">" : "<$tag>") .
631 join("\n", map { e($_) } @{$a->{$k}->{$cond}}) .
632 "</$tag>\n";
633 }
634 return $out;
635 }
637 # send out @{$a->{$k}} as a rdf:bag
638 # $k is the name of the outer tag unless overriden by $tag
639 # $i denotes the depth of indentation, inner tags are indented
640 # 2 or 4 more character positions.
641 # each element of the bag is listed
642 sub xml_bag ($$$;$) {
643 my ($i, $a, $k, $tag) = @_;
644 my ($out, $cond, $upn);
645 return "" if (not exists($a->{$k}));
646 $tag = $k if (not defined($tag));
647 $out = '';
648 $i = ' ' x $i;
649 foreach $cond (sort keys %{$a->{$k}}) {
650 next if (not @{$a->{$k}->{$cond}});
651 $upn = e(upn($cond));
652 $out .= $i .
653 ($cond ne '' ? "<$tag cond=\"$upn\">\n" : "<$tag>\n") .
654 "$i <rdf:bag>\n" .
655 join("",
656 map {
657 ref $_
658 ? "$i <resource".
659 ( exists $_->{attrname}
660 ? " $_->{attrname}=\"".e($_->{attrval})."\""
661 : ""
662 ) .
663 ">".e($_->{resource})."</resource>\n"
664 : "$i <rdf:li>".e($_)."</rdf:li>\n"
665 }
666 @{$a->{$k}->{$cond}}) .
667 "$i </rdf:bag>\n" .
668 "$i</$tag>\n";
669 }
670 return $out;
671 }
673 # send out reference to another RDF
674 sub xml_reference ($$$$$$) {
675 my($fh, $res, $href, $S, $T, $D) = @_;
676 print $fh " <Repository rdf:resource=\"$res\" href=\"$href\"";
677 if ($opt_S && defined($S) && $S ne "") {
678 print $fh " size=\"$S\"";
679 }
680 if ($opt_T && defined($T) && $T ne "") {
681 print $fh " mtime=\"$T\"";
682 }
683 if ($opt_D && defined($D) && $D ne "") {
684 print $fh " md5=\"$D\"";
685 }
686 print $fh "/>\n";
687 }
689 # send out reference to other resources
690 sub xml_other ($$$$$$) {
691 my($fh, $about, $href, $S, $T, $D) = @_;
692 print $fh " <rdf:Description about=\"$about\" href=\"$href\"";
693 if ($opt_S && defined($S) && $S ne "") {
694 print $fh " size=\"$S\"";
695 }
696 if ($opt_T && defined($T) && $T ne "") {
697 print $fh " mtime=\"$T\"";
698 }
699 if ($opt_D && defined($D) && $D ne "") {
700 print $fh " md5=\"$D\"";
701 }
702 print $fh ">\n";
703 print $fh " </rdf:Description>\n";
704 }
706 # translate attributes from %$a as generated by package2data
707 # into XML and write to file $fh
708 sub xml_record ($$$$$$) {
709 my ($fh, $a, $href, $S, $T, $D) = @_;
710 my ($maj, $min, $rel, $about);
712 $about =
713 n($a, 'Name') . '-' .
714 n($a, 'Version') . '-' .
715 n($a, 'Release');
716 if (not defined($href)) {
717 # guess location from Information in Specfile
718 if (exists($a->{'NoSource'})) {
719 $href = "$about.nosrc.rpm";
720 } else {
721 $href = "$about.src.rpm";
722 }
723 ($maj, $min, $rel) = (n($a, 'Release') =~ m/^(\d+)\.(\d+)\.(\d+)/);
724 if (defined($min)) {
725 if ($maj > 1 || ($maj == 1 && $min > 0)) {
726 # OpenPKG-1.1-RELEASE or later
727 if (n($a, 'Distribution') =~ /\[PLUS\]/) {
728 $href = 'PLUS/'.$href;
729 }
730 }
731 if ($maj > 1 || ($maj == 1 && $min >= 0)) {
732 # OpenPKG-1.0-RELEASE or later
733 if ($rel > 0) {
734 $href = 'UPD/'.$href;
735 }
736 }
737 } else {
738 # OpenPKG-CURRENT
739 }
740 }
742 print $fh " <rdf:Description about=\"$about\" href=\"$href\"";
743 if ($opt_S && defined($S) && $S ne "") {
744 print $fh " size=\"$S\"";
745 }
746 if ($opt_T && defined($T) && $T ne "") {
747 print $fh " mtime=\"$T\"";
748 }
749 if ($opt_D && defined($D) && $D ne "") {
750 print $fh " md5=\"$D\"";
751 }
752 print $fh ">\n";
754 # fake Source attribute from Source\d attribtutes
755 # XXX only default conditional
756 $a->{'Source'} = { '' => [
757 map {
758 s/\Q%{name}\E/n($a, 'Name')/esg;
759 s/\Q%{version}\E/n($a, 'Version')/esg;
760 s/\Q%{release}\E/n($a, 'Release')/esg;
761 $_;
762 }
763 map {
764 $a->{$_}->{''} ? @{$a->{$_}->{''}} : ()
765 }
766 sort {
767 my ($x) = ($a =~ /^(\d*)$/);
768 my ($y) = ($b =~ /^(\d*)$/);
769 return $x <=> $y;
770 }
771 grep {
772 /^Source\d*$/
773 } keys(%$a)
774 ]};
775 delete($a->{'Source'}) if (not @{$a->{'Source'}->{''}});
777 print $fh
778 xml_tag(6, $a, 'Name'),
779 xml_tag(6, $a, 'Version'),
780 xml_tag(6, $a, 'Release'),
781 xml_tag(6, $a, 'Distribution'),
782 xml_tag(6, $a, 'Class'),
783 xml_tag(6, $a, 'Group'),
784 xml_tag(6, $a, 'License'),
785 xml_tag(6, $a, 'Packager'),
786 xml_tag(6, $a, 'Summary'),
787 xml_tag(6, $a, 'URL'),
788 xml_tag(6, $a, 'Vendor'),
789 xml_tag(6, $a, 'SourceRPM'),
790 xml_tag(6, $a, 'Arch'),
791 xml_tag(6, $a, 'Os'),
792 xml_tag(6, $a, 'BuildHost'),
793 xml_tag(6, $a, 'BuildSystem'),
794 xml_tag(6, $a, 'BuildTime'),
795 xml_tag(6, $a, 'Relocations'),
796 xml_tag(6, $a, 'Size'),
797 xml_tag(6, $a, 'Prefixes'),
798 xml_tag(6, $a, 'Platform'),
799 xml_tag(6, $a, 'SigSize'),
800 xml_tag(6, $a, 'SigMD5'),
801 xml_tag(6, $a, 'SigPGP'),
802 xml_tag(6, $a, 'SigGPG'),
803 xml_bag(6, $a, 'BuildPreReq'),
804 xml_bag(6, $a, 'PreReq'),
805 xml_bag(6, $a, 'Provides'),
806 xml_bag(6, $a, 'Conflicts'),
807 xml_bag(6, $a, 'Source'),
808 xml_bag(6, $a, 'NoSource'),
809 xml_bag(6, $a, 'Filenames'),
810 xml_text(6, $a, 'Description');
812 print $fh " </rdf:Description>\n";
813 }
815 #############################################################################
816 ##
817 ## OpenPKG RPM Package Payload Extraction
818 ##
819 #############################################################################
821 # extract foo.spec from foo-V-R.src.rpm file
822 sub rpm2spec ($) {
823 my ($fn) = @_;
824 local($SIG{'PIPE'}) = 'IGNORE';
825 local(*PIPE);
826 open(PIPE, "$R2C '$fn' |")
827 or die "openpkg:index:FATAL: cannot read '$fn' ($!)\n";
828 my ($buf, @hdr, $n, $m, $name, $step);
829 my ($spec);
830 while (read(PIPE, $buf, 110) == 110) {
831 @hdr = unpack('a6a8a8a8a8a8a8a8a8a8a8a8a8a8', $buf);
832 $n = hex($hdr[12]); # filename length
833 $m = int(($n+5)/4)*4-2; # filename size (padded)
834 last if (not (read(PIPE,$buf,$m) == $m));
835 $name = substr($buf, 0, $n-1);
836 $n = hex($hdr[7]); # file length
837 $m = int(($n+3)/4)*4; # file size (padded)
838 if ($name !~ m/.spec$/) {
839 while ($m > 0) {
840 $step = $m > 8192 ? 8192 : $m;
841 last if (not read(PIPE,$buf,$step));
842 $m -= length($buf);
843 }
844 } else {
845 if (read(PIPE,$buf,$n) == $n) {
846 $spec = $buf;
847 }
848 last;
849 }
850 }
851 close(PIPE);
852 return $spec;
853 }
855 #############################################################################
856 ##
857 ## OpenPKG RPM Package Header Extraction
858 ##
859 #############################################################################
861 # extract header information from foo-V-R.src.rpm
862 sub rpm2data ($$) {
863 my ($fn, $platform) = @_;
864 my ($q, %a);
865 my ($t, $v);
866 local(*PIPE);
868 if (not defined($platform)) {
869 die "openpkg:index:FATAL: indexing binary package '$fn' requires -p option\n";
870 }
872 $q = <<EOFEOF;
873 Name %{Name}
874 Version %{Version}
875 Release %{Release}
876 URL %{URL}
877 Summary %{Summary}
878 Copyright %{Copyright}
879 License %{License}
880 Distribution %{Distribution}
881 Vendor %{Vendor}
882 Class %{Class}
883 Group %{Group}
884 Packager %{Packager}
885 Prefixes %{Prefixes}
886 BuildHost %{BuildHost}
887 BuildTime %{BuildTime}
888 Arch %{Arch}
889 Os %{Os}
890 Size %{Size}
891 SigSize %{SigSize}
892 SigMD5 %{SigMD5}
893 SigPGP %{SigPGP}
894 SigGPG %{SigGPG}
895 SourceRPM %{SourceRPM}
896 [Patch %{Patch}
897 ]
898 [Source %{Source}
899 ]
900 [Filenames %{Filenames}
901 ]
902 [Conflicts %{CONFLICTNAME} %|CONFLICTFLAGS?{%{CONFLICTFLAGS:depflags} %{CONFLICTVERSION}}:{}|
903 ]
904 [PreReq %{REQUIRENAME} %|REQUIREFLAGS?{%{REQUIREFLAGS:depflags} %{REQUIREVERSION}}:{}|
905 ]
906 [Provides %{PROVIDENAME} %|PROVIDEFLAGS?{%{PROVIDEFLAGS:depflags} %{PROVIDEVERSION}}:{}|
907 ]
908 Description %{Description}
909 EOFEOF
911 open(PIPE, "$RPM -qp --qf '$q' '$fn' |")
912 or die "FATAL: cannot read '$fn' ($!)\n";
913 while (<PIPE>) {
914 if (/^(\S+)\s+(.*?)\s*$/) {
915 $t = $1;
916 $v = $2;
917 } elsif (/^(\s+.+?)\s*$/) {
918 next if (not defined($t));
919 $v = $1;
920 } else {
921 $t = undef;
922 next;
923 }
924 if (exists($a{$t})) {
925 $a{$t} .= "\n$v";
926 } else {
927 $a{$t} = $v;
928 }
929 }
930 close(PIPE);
932 %a = map { $_ => $a{$_} }
933 grep { $a{$_} ne '(none)' }
934 keys(%a);
935 if ($a{'Relocations'} eq '(non relocatable)') {
936 delete($a{'Relocations'});
937 }
938 if ($a{'SigMD5'} eq '(unknown type)') {
939 delete($a{'SigMD5'});
940 }
941 if (defined($platform)) {
942 $a{'Platform'} = $platform;
943 }
944 $a{'Description'} = [ $a{'Description'} ];
946 foreach ('Conflicts', 'PreReq', 'Provides') {
947 $a{$_} = [
948 map { &$make_resource($_) }
949 grep { !/^rpmlib\(/ }
950 split(/\n+/, $a{$_})
951 ];
952 }
954 return { map {
955 $_ => { '' => (ref $a{$_} ? $a{$_} : [ split(/\n+/, $a{$_}) ]) }
956 } keys(%a) };
957 }
959 #############################################################################
960 ##
961 ## OpenPKG XML/RDF Index Locating
962 ##
963 #############################################################################
965 # detect index files
966 sub getindex ($) {
967 my ($dir) = @_;
968 my (@idx) =
969 sort { -M $a <=> -M $b; }
970 grep { -f $_ }
971 ( <$dir/00INDEX.rdf>, <$dir/00INDEX.rdf.*> );
972 return if (not @idx);
973 return $idx[0];
974 }
976 # list RPM directories of unpacked .spec files
977 sub list_specdir ($) {
978 my ($dir) = @_;
979 my ($d, $path);
980 my (@list);
982 local(*DH);
983 opendir(DH, $dir);
984 while ($d = readdir(DH)) {
985 next if ($d =~ m/^\./);
986 $path = "$dir/$d/$d.spec";
987 push(@list, $path) if (-f $path);
988 }
989 closedir(DH);
990 return \@list;
991 }
993 # list index or RPM file directories
994 sub list_rpmdir ($) {
995 my ($dir) = @_;
996 my ($d, $path);
997 my (@list, $idx, $sub);
999 local(*DH);
1000 opendir(DH, $dir);
1001 while ($d = readdir(DH)) {
1002 next if ($d =~ m/^\./);
1003 $path = "$dir/$d";
1004 if (-d $path) {
1005 $idx = getindex($path);
1006 if (defined($idx)) {
1007 push(@list, $idx);
1008 } else {
1009 $sub = list_rpmdir($path);
1010 push(@list, @$sub);
1011 undef $sub;
1012 }
1013 } else {
1014 next if (not ($d =~ m/\.(?:rpm|sh)$/ && -f $path));
1015 push(@list, $path);
1016 }
1017 }
1018 closedir(DH);
1019 return \@list;
1020 }
1022 #############################################################################
1023 ##
1024 ## OpenPKG XML/RDF Index Reading
1025 ##
1026 #############################################################################
1028 # fetch a whole file
1029 sub readfile ($) {
1030 my ($fn) = @_;
1031 local(*FH);
1032 open(FH, "< $fn")
1033 or die "FATAL: cannot read '$fn' ($!)\n";
1034 my $l; { local $/; $l = <FH>; }
1035 close(FH);
1036 return $l;
1037 }
1039 # create relative path by stripping instance prefix
1040 sub relpath ($$) {
1041 my ($prefix, $path) = @_;
1042 $path =~ s/^\Q$prefix\E\///s;
1043 return $path;
1044 }
1046 # create directory path with trailing slash
1047 sub dirname ($) {
1048 my ($path) = @_;
1049 $path =~ s/\/[^\/]*$//s;
1050 return $path.'/';
1051 }
1053 # peek at resource identifier of index file
1054 sub getresource ($) {
1055 my ($fn) = @_;
1056 my ($fh, $buf);
1058 local(*FH);
1059 if ($fn =~ /\.bz2$/) {
1060 open(FH, "$BZ -dc $fn |")
1061 or die "FATAL: cannot read '$fn' ($!)\n";
1062 } else {
1063 open(FH, "< $fn")
1064 or die "FATAL: cannot read '$fn' ($!)\n";
1065 }
1066 read(FH, $buf, 1024);
1067 close(FH);
1068 if ($buf =~ /<Repository.*?rdf:resource="([^"]+)"/) {
1069 return $1;
1070 }
1071 return undef;
1072 }
1074 #############################################################################
1075 ##
1076 ## OpenPKG XML/RDF Index Output Generation
1077 ##
1078 #############################################################################
1080 sub sizetime ($) {
1081 my ($file) = @_;
1082 my @stat = stat($file);
1083 return ($stat[7], $stat[9]);
1084 }
1086 sub digest ($) {
1087 my ($file) = @_;
1088 my $digest = "";
1089 my $output = `($OPENSSL md5 -hex "$file") 2>/dev/null || true`;
1090 if ($output =~ m/MD5\(.+?\)=\s*([0-9a-fA-F]+)/s) {
1091 $digest = uc($1);
1092 }
1093 return $digest;
1094 }
1096 sub write_index ($$$$$$) {
1097 my ($fh, $prefix, $resource, $platform, $list, $cache) = @_;
1098 my ($a, $h, $r, $spec, $T, $D);
1100 foreach (@$list) {
1101 $a = undef;
1102 $h = undef;
1103 $r = undef;
1104 $S = undef;
1105 $T = undef;
1106 $D = undef;
1107 $o = undef;
1109 # determine information
1110 if (m/\.spec$/) {
1111 $spec = readfile($_);
1112 $a = spec2data($spec);
1113 ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
1114 $D = digest($_) if ($opt_D);
1115 } elsif (m/([^\/]+\.(?:no)?src\.rpm)$/) {
1116 $h = relpath($prefix, $_);
1117 ($S, $T) = sizetime($_) if ($opt_S or $opt_T or $cache);
1118 if ($cache) {
1119 if ( exists($cache->{"T$_"})
1120 && $cache->{"T$_"} == $T
1121 && exists($cache->{"s$_"})
1122 && $cache->{"s$_"} ne ""
1123 && (!$opt_S || ($opt_S && exists($cache->{"S$_"}) && $cache->{"S$_"} ne ""))
1124 && (!$opt_D || ($opt_D && exists($cache->{"D$_"}) && $cache->{"D$_"} ne ""))) {
1125 # found in cache
1126 $spec = $cache->{"s$_"};
1127 $S = $cache->{"S$_"} if ($opt_S);
1128 $D = $cache->{"D$_"} if ($opt_D);
1129 } else {
1130 # not found in cache
1131 $spec = rpm2spec($_);
1132 $cache->{"s$_"} = $spec;
1133 $cache->{"S$_"} = $S;
1134 $cache->{"T$_"} = $T;
1135 $D = digest($_) if ($opt_D);
1136 $cache->{"D$_"} = $D if ($opt_D);
1137 }
1138 } else {
1139 # no cache at all
1140 $spec = rpm2spec($_);
1141 $D = digest($_) if ($opt_D);
1142 }
1143 $a = spec2data($spec);
1144 } elsif (m/([^\/]+\.rpm)$/) {
1145 $h = relpath($prefix, $_);
1146 $a = rpm2data($_, $platform);
1147 ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
1148 $D = digest($_) if ($opt_D);
1149 } elsif (m/(([^\/]+)\.(?:no)?src\.sh)$/) {
1150 $h = relpath($prefix, $_);
1151 ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
1152 $D = digest($_) if ($opt_D);
1153 $o = "$2:bootstrap";
1154 } elsif (m/([^\/]+\.rdf[^\/]*)$/) {
1155 $h = relpath($prefix, $_);
1156 $r = getresource($_) || $resource.dirname($h);
1157 ($S, $T) = sizetime($_) if ($opt_S or $opt_T);
1158 $D = digest($_) if ($opt_D);
1159 }
1161 # process information
1162 if ($a) {
1163 xml_record($fh, $a, $h, $S, $T, $D);
1164 } elsif ($o) {
1165 xml_other($fh, $o, $h, $S, $T, $D);
1166 } elsif ($r) {
1167 xml_reference($fh, $r, $h, $S, $T, $D);
1168 } else {
1169 warn "openpkg:index:ERROR: cannot process $_";
1170 }
1171 }
1172 }
