comparison: openpkg/index.pl
openpkg/index.pl
- changeset 794
- 07be25b95aca
equal
deleted
inserted
replaced
| -1:000000000000 | 0:2dc08ccae999 |
|---|---|
| 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 ## | |
| 23 | |
| 24 ############################################################################# | |
| 25 ## | |
| 26 ## MAIN PROCEDURE | |
| 27 ## | |
| 28 ############################################################################# | |
| 29 | |
| 30 require 5; | |
| 31 #use strict; | |
| 32 | |
| 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 } | |
| 51 | |
| 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"; | |
| 59 | |
| 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 } | |
| 68 | |
| 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 } | |
| 87 | |
| 88 # provide default for repository path | |
| 89 $opt_r = 'OpenPKG-CURRENT/Source/' if (not defined($opt_r)); | |
| 90 | |
| 91 # create make_resource function closure | |
| 92 my $make_resource = gen_make_resource(); | |
| 93 | |
| 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; | |
| 116 | |
| 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); | |
| 134 | |
| 135 # close output channel | |
| 136 close($fh) | |
| 137 or die "openpkg:index:FATAL: write error on output ($!)"; | |
| 138 | |
| 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 } | |
| 144 | |
| 145 # die gracefully | |
| 146 exit(0); | |
| 147 | |
| 148 ############################################################################# | |
| 149 ## | |
| 150 ## FUNCTIONS: PARSING | |
| 151 ## | |
| 152 ############################################################################# | |
| 153 | |
| 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); | |
| 159 | |
| 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 } | |
| 204 | |
| 205 ############################################################################# | |
| 206 ## | |
| 207 ## OpenPKG RPM Package Specification Parsing | |
| 208 ## | |
| 209 ############################################################################# | |
| 210 | |
| 211 # escape XML for output in RDF file | |
| 212 sub e ($) { | |
| 213 my ($s) = @_; | |
| 214 my ($i); | |
| 215 | |
| 216 # remove trailing whitespace | |
| 217 $s =~ s/\n+$//sg; | |
| 218 $s =~ s/[^\S\n]+$//mg; | |
| 219 | |
| 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)); | |
| 226 | |
| 227 # escape XML special characters | |
| 228 $s =~ s/&/&/sg; | |
| 229 $s =~ s/</</sg; | |
| 230 $s =~ s/>/>/sg; | |
| 231 | |
| 232 return $s; | |
| 233 } | |
| 234 | |
| 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); | |
| 257 | |
| 258 # return function which makes resource object | |
| 259 return sub ($) { | |
| 260 my ($s) = @_; | |
| 261 | |
| 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 }; | |
| 276 | |
| 277 # split string into array at comma seperator | |
| 278 # (optioanlly map resource operators into resource objects) | |
| 279 sub commasep ($$) { | |
| 280 my ($k, $v) = @_; | |
| 281 | |
| 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 } | |
| 290 | |
| 291 # escape option string | |
| 292 sub optesc ($) { | |
| 293 my ($s) = @_; | |
| 294 | |
| 295 $s =~ s/([\x00-\x1f\x80-\xbf\s\%])/sprintf("%%%02x", ord($1))/eg; | |
| 296 return $s; | |
| 297 } | |
| 298 | |
| 299 # variable substitution | |
| 300 sub vsub ($$) { | |
| 301 my ($var, $v) = @_; | |
| 302 | |
| 303 $v =~ s/\%\{([^}]+)\}/ | |
| 304 exists $var->{$1} ? $var->{$1} : '%{'.$1.'}'/emg; | |
| 305 return $v; | |
| 306 } | |
| 307 | |
| 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); | |
| 317 | |
| 318 # split string into tokens | |
| 319 @tok = ($t =~ m/(\(|\)|\&\&|\|\||\!|\S+)/g); | |
| 320 | |
| 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 } | |
| 351 | |
| 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 } | |
| 360 | |
| 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); | |
| 376 | |
| 377 # combine multilines (line continuation!) | |
| 378 $s =~ s/\\\n/ /sg; | |
| 379 | |
| 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; | |
| 383 | |
| 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; | |
| 386 | |
| 387 # use option variables for expansion | |
| 388 %evar = %$ovar; | |
| 389 | |
| 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; | |
| 400 | |
| 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 } | |
| 409 | |
| 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)); | |
| 417 | |
| 418 if (($p) = ($v =~ /^\#if\s+(.*?)\s*$/)) { | |
| 419 # normalize "%{variable}" != ..." | |
| 420 $p =~ s/("\%\{[^}]+\}")\s*!=\s*"(yes|no)"/$1 . " == \"" . ($2 ne "yes" ? "yes" : "no") . "\""/sge; | |
| 421 | |
| 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 } | |
| 443 | |
| 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)); | |
| 515 | |
| 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 } | |
| 523 | |
| 524 # return all header "attributes" | |
| 525 return \%attr; | |
| 526 } | |
| 527 | |
| 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; | |
| 539 | |
| 540 # remove comments | |
| 541 $s =~ s/^\s*#.*?\n//mg; | |
| 542 | |
| 543 # map commands | |
| 544 $s =~ s/^%(ifdef|ifndef|if|NoSource|option|undefine|define|else|endif|\{)/#$1/mg; | |
| 545 | |
| 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 } | |
| 554 | |
| 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 } | |
| 567 | |
| 568 ############################################################################# | |
| 569 ## | |
| 570 ## XML/RDF Generation | |
| 571 ## | |
| 572 ############################################################################# | |
| 573 | |
| 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 } | |
| 584 | |
| 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 } | |
| 593 | |
| 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 } | |
| 601 | |
| 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 } | |
| 613 | |
| 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 } | |
| 636 | |
| 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 } | |
| 672 | |
| 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 } | |
| 688 | |
| 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 } | |
| 705 | |
| 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); | |
| 711 | |
| 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 } | |
| 741 | |
| 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"; | |
| 753 | |
| 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'}->{''}}); | |
| 776 | |
| 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'); | |
| 811 | |
| 812 print $fh " </rdf:Description>\n"; | |
| 813 } | |
| 814 | |
| 815 ############################################################################# | |
| 816 ## | |
| 817 ## OpenPKG RPM Package Payload Extraction | |
| 818 ## | |
| 819 ############################################################################# | |
| 820 | |
| 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 } | |
| 854 | |
| 855 ############################################################################# | |
| 856 ## | |
| 857 ## OpenPKG RPM Package Header Extraction | |
| 858 ## | |
| 859 ############################################################################# | |
| 860 | |
| 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); | |
| 867 | |
| 868 if (not defined($platform)) { | |
| 869 die "openpkg:index:FATAL: indexing binary package '$fn' requires -p option\n"; | |
| 870 } | |
| 871 | |
| 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 | |
| 910 | |
| 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); | |
| 931 | |
| 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'} ]; | |
| 945 | |
| 946 foreach ('Conflicts', 'PreReq', 'Provides') { | |
| 947 $a{$_} = [ | |
| 948 map { &$make_resource($_) } | |
| 949 grep { !/^rpmlib\(/ } | |
| 950 split(/\n+/, $a{$_}) | |
| 951 ]; | |
| 952 } | |
| 953 | |
| 954 return { map { | |
| 955 $_ => { '' => (ref $a{$_} ? $a{$_} : [ split(/\n+/, $a{$_}) ]) } | |
| 956 } keys(%a) }; | |
| 957 } | |
| 958 | |
| 959 ############################################################################# | |
| 960 ## | |
| 961 ## OpenPKG XML/RDF Index Locating | |
| 962 ## | |
| 963 ############################################################################# | |
| 964 | |
| 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 } | |
| 975 | |
| 976 # list RPM directories of unpacked .spec files | |
| 977 sub list_specdir ($) { | |
| 978 my ($dir) = @_; | |
| 979 my ($d, $path); | |
| 980 my (@list); | |
| 981 | |
| 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 } | |
| 992 | |
| 993 # list index or RPM file directories | |
| 994 sub list_rpmdir ($) { | |
| 995 my ($dir) = @_; | |
| 996 my ($d, $path); | |
| 997 my (@list, $idx, $sub); | |
| 998 | |
| 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 } | |
| 1021 | |
| 1022 ############################################################################# | |
| 1023 ## | |
| 1024 ## OpenPKG XML/RDF Index Reading | |
| 1025 ## | |
| 1026 ############################################################################# | |
| 1027 | |
| 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 } | |
| 1038 | |
| 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 } | |
| 1045 | |
| 1046 # create directory path with trailing slash | |
| 1047 sub dirname ($) { | |
| 1048 my ($path) = @_; | |
| 1049 $path =~ s/\/[^\/]*$//s; | |
| 1050 return $path.'/'; | |
| 1051 } | |
| 1052 | |
| 1053 # peek at resource identifier of index file | |
| 1054 sub getresource ($) { | |
| 1055 my ($fn) = @_; | |
| 1056 my ($fh, $buf); | |
| 1057 | |
| 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 } | |
| 1073 | |
| 1074 ############################################################################# | |
| 1075 ## | |
| 1076 ## OpenPKG XML/RDF Index Output Generation | |
| 1077 ## | |
| 1078 ############################################################################# | |
| 1079 | |
| 1080 sub sizetime ($) { | |
| 1081 my ($file) = @_; | |
| 1082 my @stat = stat($file); | |
| 1083 return ($stat[7], $stat[9]); | |
| 1084 } | |
| 1085 | |
| 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 } | |
| 1095 | |
| 1096 sub write_index ($$$$$$) { | |
| 1097 my ($fh, $prefix, $resource, $platform, $list, $cache) = @_; | |
| 1098 my ($a, $h, $r, $spec, $T, $D); | |
| 1099 | |
| 1100 foreach (@$list) { | |
| 1101 $a = undef; | |
| 1102 $h = undef; | |
| 1103 $r = undef; | |
| 1104 $S = undef; | |
| 1105 $T = undef; | |
| 1106 $D = undef; | |
| 1107 $o = undef; | |
| 1108 | |
| 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 } | |
| 1160 | |
| 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 } | |
| 1173 |
