openpkg/index.pl@c10fb90893b9
openpkg/index.pl
Thu, 04 Oct 2012 20:30:05 +0200
- author
- Michael Schloh von Bennewitz <michael@schloh.com>
- date
- Thu, 04 Oct 2012 20:30:05 +0200
- changeset 715
- c10fb90893b9
- permissions
- -rw-r--r--
Correct out of date build configuration, porting to Solaris 11 network
link infrastructure and new libpcap logic. This additionally allows for
device drivers in subdirectories of /dev. Correct packaged nmap
personalities and signatures to work out of the box. Finally, hack
arpd logic to properly close sockets and quit on TERM by repeating
signaling in the run command script. Sadly, all this fails to correct
the run time behaviour of honeyd which fails to bind to the IP layer.
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 }
